unit uGHWReader ;

interface

uses
  Windows,
  Classes,
  SysUtils,
  Contnrs ;

type

  TSLVType = ( //
    slvU = 0, // Uninitialized
    slvX = 1, // Unknown

    slv0 = 2, // Forcing 0
    slv1 = 3, // Forcing 1

    slvZ = 4, // High Impedance
    slvW = 5, // Weak Unknown

    slvL = 6, // Weak 0
    slvH = 7, // Weak 1

    slvD = 8 // Don't care
    ) ;

  ghdl_rtik_t = ( //
    ghdl_rtik_top, ghdl_rtik_library, ghdl_rtik_package, ghdl_rtik_package_body, //
    ghdl_rtik_entity, ghdl_rtik_architecture, ghdl_rtik_process, ghdl_rtik_block, //
    ghdl_rtik_if_generate, ghdl_rtik_for_generate, ghdl_rtik_instance, ghdl_rtik_constant, //
    ghdl_rtik_iterator, ghdl_rtik_variable, ghdl_rtik_signal, ghdl_rtik_file, //
    ghdl_rtik_port, ghdl_rtik_generic, ghdl_rtik_alias, ghdl_rtik_guard, //
    ghdl_rtik_component, ghdl_rtik_attribute, //

    ghdl_rtik_type_b2, ghdl_rtik_type_e8, ghdl_rtik_type_e32, ghdl_rtik_type_i32, //
    ghdl_rtik_type_i64, ghdl_rtik_type_f64, ghdl_rtik_type_p32, ghdl_rtik_type_p64, //

    ghdl_rtik_type_access, ghdl_rtik_type_array, ghdl_rtik_type_record, ghdl_rtik_type_file, //
    ghdl_rtik_subtype_scalar, ghdl_rtik_subtype_array, ghdl_rtik_subtype_array_ptr, //
    ghdl_rtik_subtype_unconstrained_array, ghdl_rtik_subtype_record, ghdl_rtik_subtype_access, //
    ghdl_rtik_type_protected, ghdl_rtik_element, ghdl_rtik_unit, ghdl_rtik_attribute_transaction, //
    ghdl_rtik_attribute_quiet, ghdl_rtik_attribute_stable, ghdl_rtik_error ) ;

  ghw_wkt_type_t = ( ghw_wkt_unknown, ghw_wkt_boolean, ghw_wkt_bit, ghw_wkt_std_ulogic ) ;

  ghw_hie_kind_t = ( //
    ghw_hie_eoh = 0, ghw_hie_design = 1, ghw_hie_block = 3, ghw_hie_generate_if = 4, //
    ghw_hie_generate_for = 5, ghw_hie_instance = 6, ghw_hie_package = 7, ghw_hie_process = 13, //
    ghw_hie_generic = 14, ghw_hie_eos = 15, ghw_hie_signal = 16, ghw_hie_port_in = 17, //
    ghw_hie_port_out = 18, ghw_hie_port_inout = 19, ghw_hie_port_buffer = 20, ghw_hie_port_linkage = 21 //
    ) ;

type
  TGHW = class ;
  TGHWHie = class ;
  TGHWReader = class ;
  TGHWType = class ;
  TGHWRange = class ;

  TGHWValueType = ( { b2_t, e8_t, int32_t, } int64_t, double_t ) ;

  TGHWValue = record
    case TGHWValueType of
      int64_t :
        ( i64 : int64 ) ;
      double_t :
        ( f64 : double ) ;
  end ;

  TGHWBlock = record
    Child : TGHWHie ;
    iter_type : TGHWType ;
    iter_value : TGHWValue ;
  end ;

  TGHWSignal = class ;

  TGHWLib = class
  private
    class var fStream : TBytes ;
    class var fIndex : integer ;

  public
    class procedure ReadByte( out aRes : byte ) ;
    class function ReadBytes( out aRes : array of byte ; aLen : integer ) : integer ;
    class procedure ReadChar( out aRes : ansichar ) ;
    class procedure ReadF64( out aRes : double ) ;
    class procedure ReadLSLEB128( out aRes : int64 ) ;
    class procedure ReadULEB128( out aRes : uint32 ) ;
    class procedure ReadSLEB128( out aRes : int32 ) ;
    class procedure ReadStrID( out aRes : string ) ;
    class procedure ReadTypeID( out aRes : TGHWType ) ;
    class procedure ReadRange( out aRes : TGHWRange ) ;
    class procedure ReadValue( const aType : TGHWType ; out aRes : TGHWValue ) ;
    class procedure ReadSignal( const aType : TGHWType ; out aSig : TGHWSignal ) ;

  public
    class procedure ReadHie ;
    class procedure ReadSnapshot ;
    class procedure ReadTypes ;
    class procedure ReadWellKnownTypes ;
    class procedure ReadEOH ;
    class procedure ReadDirectory ;
    class procedure ReadTailer ;
    class procedure ReadCycles ;
    class procedure ReadStrings ;

  public
    class function EOF : boolean ;
    class function Open( aFilename : string ) : boolean ;
    class procedure Close ;
    class function Opened : boolean ;
    class function FileExists( aFilename : string ) : boolean ;
  end ;

  TGHWLibProc = procedure of object ;

  PGHWHie = ^TGHWHie ;

  TGHWVisitor = class ;

  TGHW = class
  private
    fName : string ;
    fParent : TGHW ;

    procedure SetName( const Value : string ) ; virtual ;
    function GetNbrOfElem : integer ; virtual ;
    procedure SetNbrOfElem( aValue : integer ) ; virtual ;
    function GetDisplayName : string ; virtual ;
    procedure SetParent( const Value : TGHW ) ;
    function GetHint( index : integer ) : string ; virtual ;
  public
    constructor Create ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; virtual ; abstract ;
    property name : string read fName write SetName ;
    property Parent : TGHW read fParent write SetParent ;
    property NbrOfElem : integer read GetNbrOfElem write SetNbrOfElem ;
    property DisplayName : string read GetDisplayName ;
    property Hint[ index : integer ] : string read GetHint ;
    function HintAt( aTime : int64 ) : string ; virtual ;
  end ;

  TGHWValueFormat = ( fmtNone, fmtHex, fmtDecimal, fmtOctal, fmtBinary, fmtFloat, fmtEnum, fmtPB3, fmtPB6, fmtMBL ) ;
  TGHWFormatChoices = set of TGHWValueFormat ;

  TGHWType = class( TGHW )
  private
    fKind : ghdl_rtik_t ;

    function GetBasetype : TGHWType ; virtual ;
    procedure SetBaseType( const Value : TGHWType ) ; virtual ;
    procedure SetKind( const Value : ghdl_rtik_t ) ;
    function GetChoices : TGHWFormatChoices ; virtual ;
    function GetFormat : TGHWValueFormat ; virtual ;
  public
    property Kind : ghdl_rtik_t read fKind write SetKind ;
    property BaseType : TGHWType read GetBasetype write SetBaseType ;
    property Choices : TGHWFormatChoices read GetChoices ;
    property ValueFormat : TGHWValueFormat read GetFormat ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      virtual ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
      overload ; virtual ;
  end ;

  TGHWEvent = record
    time : int64 ;
    val : TGHWValue ;
    idx : integer ;
  end ;

  TGHWSignal = class( TGHW )
  private
    class var fSignals : TObjectlist ;
  public
    class function Factory( aType : TGHWType ; index : integer = 0 ) : TGHWSignal ;
    class procedure CleanUp ;
    class procedure Clear ;

  private
    fSignalType : TGHWType ;
    fIndex : integer ;
    fEvents : array of TGHWEvent ;
    fNext : integer ;
    fValueFormat : TGHWValueFormat ;

    function GetDisplayName : string ; override ;
    procedure SetIndex( const Value : integer ) ;

    function GetSignals( index : integer ) : TGHWSignal ; virtual ;
    procedure SetSignals( index : integer ; const Value : TGHWSignal ) ; virtual ;
    function GetCount : integer ; virtual ;
    procedure SetCount( const Value : integer ) ; virtual ;
    function GetEvent( index : integer ) : TGHWEvent ; virtual ;
    function GetEventCount : integer ; virtual ;
    procedure SetSignalType( const Value : TGHWType ) ;
    function GetHint( index : integer ) : string ; override ;
    procedure SetValueFormat( const Value : TGHWValueFormat ) ;
  public
    constructor Create ;
    destructor Destroy ; override ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;

    property index : integer read fIndex write SetIndex ;
    property SignalType : TGHWType read fSignalType write SetSignalType ;

    property Events[ index : integer ] : TGHWEvent read GetEvent ;
    procedure AddEvent( aTime : int64 ; aVal : TGHWValue ) ; overload ; virtual ;
    procedure AddEvent( aEvent : TGHWEvent ) ; overload ; virtual ;
    property EventCount : integer read GetEventCount ;
    function IndexOf( aTime : int64 ) : integer ; virtual ;

    property Signals[ index : integer ] : TGHWSignal read GetSignals write SetSignals ; default ;
    property Count : integer read GetCount write SetCount ;
    function AsString( aTime : int64 ) : string ; overload ; virtual ;
    function AsString( aIndex : integer ) : string ; overload ; virtual ;

    procedure ReadCycle( aTime : int64 ) ;
    function ValueAt( aTime : int64 ) : TGHWValue ;
    procedure Resize ; virtual ;
    function HintAt( aTime : int64 ) : string ; override ;

    property ValueFormat : TGHWValueFormat read fValueFormat write SetValueFormat ;
  end ;

  TGHWSignalArray = class( TGHWSignal )
  private
    fSignals : TObjectlist ;

    function GetSignals( index : integer ) : TGHWSignal ; override ;
    procedure SetSignals( index : integer ; const Value : TGHWSignal ) ; override ;
    function GetCount : integer ; override ;
    procedure SetCount( const Value : integer ) ; override ;

    function GetEventCount : integer ; override ;
    procedure QuickSort( l, r : integer ) ;
  public
    constructor Create ;
    destructor Destroy ; override ;

    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    function AsString( aTime : int64 ) : string ; overload ; override ;
    function AsString( aIndex : integer ) : string ; overload ; override ;
  end ;

  TGHWSignalRecord = class( TGHWSignalArray )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    function AsString( aTime : int64 ) : string ; overload ; override ;
    function AsString( aIndex : integer ) : string ; overload ; override ;
  end ;

  TGHWHie = class( TGHW )
  private
    fKind : ghw_hie_kind_t ;
    fBrother : TGHWHie ;
    fBlock : TGHWBlock ;
    fSignalType : TGHWType ;
    fSignals : TGHWSignal ;
    fNewest : int64 ;
    fOldest : int64 ;

  private
    function GetSignalType : TGHWType ; virtual ;
    procedure SetSignalType( const Value : TGHWType ) ; virtual ;
    procedure SetKind( const Value : ghw_hie_kind_t ) ;
    procedure SetSignals( const Value : TGHWSignal ) ;
    function GetDisplayName : string ; override ;
  public

    property SignalType : TGHWType read GetSignalType write SetSignalType ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property Signals : TGHWSignal read fSignals write SetSignals ;
    property Oldest : int64 read fOldest ;
    property Newest : int64 read fNewest write fNewest ;
    property Kind : ghw_hie_kind_t read fKind write SetKind ;
    property Brother : TGHWHie read fBrother ;
    property Child : TGHWHie read fBlock.Child ;
    property Block : TGHWBlock read fBlock ;

  private
    class var fHierObjects : TObjectlist ;
  public
    class function Factory( aKind : ghw_hie_kind_t ) : TGHWHie ;
    class procedure Clear ;
  end ;

  TGHWHieEOH = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieDesign = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieInstance = class( TGHWHie )
  private
    function GetHint( index : integer ) : string ; override ;
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieBlock = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieGenerateIf = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieGenerateFor = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieProcess = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieGeneric = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  // End Of Scope
  TGHWHieEOS = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHiePackage = class( TGHWHie )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHieSignal = class( TGHWHie )
  private
    function GetHint( index : integer ) : string ; override ;
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    function HintAt( aTime : int64 ) : string ; override ;
  end ;

  TGHWHiePort = class( TGHWHieSignal )
  private
  public
  end ;

  TGHWHiePortIn = class( TGHWHiePort )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHiePortOut = class( TGHWHiePort )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHiePortInOut = class( TGHWHiePort )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHiePortBuffer = class( TGHWHiePort )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWHiePortLinkage = class( TGHWHiePort )
  private
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
  end ;

  TGHWRange = class( TGHWType )
  private
    fRight : double ;
    fDir : boolean ;
    fLeft : double ;

    function GetDisplayName : string ; override ;
    function GetLength : integer ;
    procedure SetDir( const Value : boolean ) ;
    procedure SetLeft( const Value : double ) ;
    procedure SetRight( const Value : double ) ;
  public
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property Length : integer read GetLength ;
    function IndexToRange( aIndex : integer ) : integer ;

    property Dir : boolean read fDir write SetDir ;
    property Left : double read fLeft write SetLeft ;
    property Right : double read fRight write SetRight ;

    // factory
  private
    class var fRanges : TObjectlist ;
  public
    class function Factory : TGHWRange ;
    class procedure Clear ;
  end ;

  TGHWTypeEnum = class( TGHWType )
  private
    fWKT : ghw_wkt_type_t ;
    fLiterals : array of string ;

    function GetDisplayName : string ; override ;
    function GetNbrOfElem : integer ; override ;
    procedure SetNbrOfElem( aValue : integer ) ; override ;
    procedure SetWKT( const Value : ghw_wkt_type_t ) ;
    function GetLiterals( index : integer ) : string ;
    procedure SetLiterals( index : integer ; const Value : string ) ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    destructor Destroy ; override ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property WKT : ghw_wkt_type_t read fWKT write SetWKT ;
    property Literals[ index : integer ] : string read GetLiterals write SetLiterals ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWUnit = record
    name : string ;
    Value : int64 ;
  end ;

  TGHWTypeScalar = class( TGHWType )
  private
    function GetDisplayName : string ; override ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWTypePhysical = class( TGHWType )
  private
    fUnits : array of TGHWUnit ;

    function GetDisplayName : string ; override ;
    function GetNbrOfElem : integer ; override ;
    procedure SetNbrOfElem( aValue : integer ) ; override ;
    function GetUnits( index : integer ) : TGHWUnit ;
    procedure SetUnits( index : integer ; const Value : TGHWUnit ) ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    destructor Destroy ; override ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;

    property Units[ index : integer ] : TGHWUnit read GetUnits write SetUnits ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWRecordElement = record
    name : string ;
    typ : TGHWType ;
  end ;

  TGHWTypeRecord = class( TGHWType )
  private
    fRecElems : array of TGHWRecordElement ;

    function GetDisplayName : string ; override ;
    function GetNbrOfElem : integer ; override ;
    procedure SetNbrOfElem( aValue : integer ) ; override ;
    function GetRecElems( index : integer ) : TGHWRecordElement ;
    procedure SetRecElems( index : integer ; const Value : TGHWRecordElement ) ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    destructor Destroy ; override ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property RecElems[ index : integer ] : TGHWRecordElement read GetRecElems write SetRecElems ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWTypeArray = class( TGHWType )
  private
    fElemType : TGHWType ;
    fDims : array of TGHWType ;

    function GetDisplayName : string ; override ;
    function GetNbrOfElem : integer ; override ;
    procedure SetNbrOfElem( aValue : integer ) ; override ;
    function GetElementType : TGHWType ; virtual ;
    procedure SetElementType( const Value : TGHWType ) ; virtual ;
    function GetDims( index : integer ) : TGHWType ;
    procedure SetDims( index : integer ; const Value : TGHWType ) ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    destructor Destroy ; override ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property ElementType : TGHWType read GetElementType write SetElementType ;
    property Dims[ index : integer ] : TGHWType read GetDims write SetDims ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWTypeBased = class( TGHWType )
  private
    fBaseType : TGHWType ;

    function GetBasetype : TGHWType ; override ;
    procedure SetBaseType( const Value : TGHWType ) ; override ;
  end ;

  TGHWSubTypeArray = class( TGHWTypeBased )
  private
    fNbrOfElem : integer ;
    fRanges : array of TGHWRange ;

    function GetDisplayName : string ; override ;
    function GetNbrOfElem : integer ; override ;
    procedure SetNbrOfElem( aValue : integer ) ; override ;
    function GetNbrOfRanges : integer ;
    procedure SetNbrOfRanges( const Value : integer ) ;
    function GetRanges( index : integer ) : TGHWRange ;
    procedure SetRanges( index : integer ; const Value : TGHWRange ) ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    destructor Destroy ; override ;
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property Ranges[ index : integer ] : TGHWRange read GetRanges write SetRanges ;
    property NbrOfRanges : integer read GetNbrOfRanges write SetNbrOfRanges ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWSubTypeScalar = class( TGHWTypeBased )
  private
    fRange : TGHWRange ;

    function GetDisplayName : string ; override ;
    procedure SetRange( const Value : TGHWRange ) ;
    function GetChoices : TGHWFormatChoices ; override ;
    function GetFormat : TGHWValueFormat ; override ;
  public
    function Accept( Visitor : TGHWVisitor ) : TObject ; override ;
    property Range : TGHWRange read fRange write SetRange ;

    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ; overload ;
      override ;
    function SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ; overload ;
      override ;
  end ;

  TGHWReader = class
  private
    // debug
    nbr_basic_sigs : uint32 ;
    nbr_sigs : uint32 ;
    nbr_scopes : uint32 ;
    nbr_str : uint32 ;
    nbr_types : uint32 ;

    fFilename : string ;
    fVersion : byte ;
    fWord_be : boolean ;
    fWord_len : byte ;
    fOff_len : byte ;

    // String table
    fStrings : TStringList ;

    // Type table
    fTypes : TObjectlist ;

    // Hierarchy
    fHie : TGHWHie ;

    // Time of the next cycle
    fSnaptime : int64 ;

  public
    fSignals : TObjectlist ; // Non-composite (or basic) signals

  private
    // properties
    function GetNbrStrings : uint32 ;
    function GetNbrTypes : uint32 ;

    function GetStrings( index : integer ) : string ;
    function GetTypes( index : integer ) : TGHWType ;
    procedure SetSnapTime( const Value : int64 ) ;
    function ReadSection( out aProc : TGHWLibProc ) : integer ;
    function GetSignals( index : integer ) : TGHWSignal ;
    function GetNbrSignals : uint32 ;
    procedure SetNbrStrings( const Value : uint32 ) ;
    procedure SetSignals( index : integer ; const Value : TGHWSignal ) ;
  public
    constructor Create ;
    destructor Destroy ; override ;
    procedure Clear ;

    function Open( aFilename : string ) : boolean ;
    procedure Close ;

    function FileExists( aFilename : string ) : boolean ;
    function Opened : boolean ;
    procedure ReadSections ;
    function KindToString( aKind : ghdl_rtik_t ) : string ;

  public
    property Hierarchy : TGHWHie read fHie ;

    property SnapTime : int64 read fSnaptime write SetSnapTime ;
    procedure AddTime( delta : int64 ) ;

    property Types[ index : integer ] : TGHWType read GetTypes ;
    property Strings[ index : integer ] : string read GetStrings ;
    property Signals[ index : integer ] : TGHWSignal read GetSignals write SetSignals ;

    procedure AddString( s : string ) ;
    procedure AddType( t : TGHWType ) ;

    property NbrStrings : uint32 read GetNbrStrings write SetNbrStrings ;
    property NbrTypes : uint32 read GetNbrTypes ;
    property NbrSignals : uint32 read GetNbrSignals ;
  end ;

  TGHWVisitor = class
  public
    function Visit( Instance : TGHWHie ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWHieDesign ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWHieInstance ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWHieGenerateFor ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWHieGenerateIf ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWHieSignal ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWRange ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWSignal ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWSignalArray ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWSignalRecord ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWSubTypeArray ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWSubTypeScalar ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWTypeArray ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWTypeEnum ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWTypePhysical ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWTypeRecord ) : TObject ; overload ; virtual ; abstract ;
    function Visit( Instance : TGHWTypeScalar ) : TObject ; overload ; virtual ; abstract ;
  end ;

function BinFormat( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
function OctFormat( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
function HexFormat( const aLen : integer ; const aArg, aMask : uint64 ) : string ;

var
  gReader : TGHWReader ;

implementation

{$ASSERTIONS ON}

uses
  IOUtils,
  Math ;

var
  gName : string ;

function BinFormat( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
var
  s : string ;
  v, m : uint64 ;
  i : integer ;
begin
  s := '' ;
  v := aArg ;
  m := aMask ;
  for i := 0 to aLen - 1 do begin
    if ( i > 0 ) and ( ( i mod 4 ) = 0 ) then
      s := '_' + s ;
    if not odd( m ) then
      s := 'X' + s
    else if odd( v ) then
      s := '1' + s
    else
      s := '0' + s ;
    v := v shr 1 ;
    m := m shr 1 ;
  end ;
  Result := Format( '%db"%s"', [ aLen, s ] ) ;
end ;

function OctFormat( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
var
  s : string ;
  v, m : uint64 ;
  i : integer ;
begin
  s := '' ;
  v := aArg ;
  m := aMask ;
  for i := 0 to ( aLen + 2 ) div 3 - 1 do begin
    if ( i > 0 ) and ( ( i mod 4 ) = 0 ) then
      s := '_' + s ;
    if ( m and 7 ) <> 7 then
      s := 'X' + s
    else
      s := Chr( Ord( '0' ) + ( v and 7 ) ) + s ;
    v := v shr 3 ;
    m := m shr 3 ;
  end ;
  Result := Format( '%do"%s"', [ aLen, s ] ) ;
end ;

function HexFormat( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
var
  s : string ;
  v, m : uint64 ;
  i : integer ;
begin
  s := '' ;
  v := aArg ;
  m := aMask ;
  for i := 0 to ( aLen + 3 ) div 4 - 1 do begin
    if ( i > 0 ) and ( ( i mod 4 ) = 0 ) then
      s := '_' + s ;
    if ( m and 15 ) <> 15 then
      s := 'X' + s
    else if ( v and 15 ) < 10 then
      s := Chr( Ord( '0' ) + ( v and 15 ) - 0 ) + s
    else
      s := Chr( Ord( 'A' ) + ( v and 15 ) - 10 ) + s ;
    v := v shr 4 ;
    m := m shr 4 ;
  end ;
  Result := Format( '%dx"%s"', [ aLen, s ] ) ;
end ;

function PB3Format( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
  function sX : string ;
  begin
    Result := Format( 's%X', [ ( aArg shr 8 ) and 15 ] ) ;
  end ;

  function sY : string ;
  begin
    Result := Format( 's%X', [ ( aArg shr 4 ) and 15 ] ) ;
  end ;

  function kk : string ;
  begin
    Result := Format( '0x%.02X', [ aArg and 255 ] ) ;
  end ;

  function Loc : string ;
  begin
    Result := Format( '0x%.03X', [ aArg and 1023 ] ) ;
  end ;

  function Cond : string ;
  begin
    case ( aArg shr 10 ) and 3 of
      0 :
        Result := 'Z' ;
      1 :
        Result := 'NZ' ;
      2 :
        Result := 'C' ;
      3 :
        Result := 'NC' ;
    else
      Result := '??' ;
    end ;
  end ;

begin
  case aArg of
    $00000 .. $00FFF :
      Result := 'MOVE ' + sX + ', ' + kk ;
    $01000 .. $01FFF :
      Result := 'MOVE ' + sX + ', ' + sY ;
    $04000 .. $04FFF :
      Result := 'IN ' + sX + ', ' + kk ;
    $05000 .. $05FFF :
      Result := 'IN ' + sX + ', ' + sY ;
    $06000 .. $06FFF :
      Result := 'LD ' + sX + ', ' + kk ;
    $07000 .. $07FFF :
      Result := 'LD ' + sX + ', ' + sY ;

    $0A000 .. $0AFFF :
      Result := 'AND ' + sX + ', ' + kk ;
    $0B000 .. $0BFFF :
      Result := 'AND ' + sX + ', ' + sY ;
    $0C000 .. $0CFFF :
      Result := 'OR ' + sX + ', ' + kk ;
    $0D000 .. $0DFFF :
      Result := 'OR ' + sX + ', ' + sY ;
    $0E000 .. $0EFFF :
      Result := 'XOR ' + sX + ', ' + kk ;
    $0F000 .. $0FFFF :
      Result := 'XOR ' + sX + ', ' + sY ;

    $12000 .. $12FFF :
      Result := 'TEST ' + sX + ', ' + kk ;
    $13000 .. $13FFF :
      Result := 'TEST ' + sX + ', ' + sY ;
    $14000 .. $14FFF :
      Result := 'COMP ' + sX + ', ' + kk ;
    $15000 .. $15FFF :
      Result := 'COMP' + sX + ', ' + sY ;

    $18000 .. $18FFF :
      Result := 'ADD ' + sX + ', ' + kk ;
    $19000 .. $19FFF :
      Result := 'ADD ' + sX + ', ' + sY ;
    $1A000 .. $1AFFF :
      Result := 'ADDC ' + sX + ', ' + kk ;
    $1B000 .. $1BFFF :
      Result := 'ADDC ' + sX + ', ' + sY ;
    $1C000 .. $1CFFF :
      Result := 'SUB ' + sX + ', ' + kk ;
    $1D000 .. $1DFFF :
      Result := 'SUB ' + sX + ', ' + sY ;
    $1E000 .. $1EFFF :
      Result := 'SUBC ' + sX + ', ' + kk ;
    $1F000 .. $1FFFF :
      Result := 'SUBC ' + sX + ', ' + sY ;

    $20000 .. $20FFF :
      case aArg and 255 of
        2 :
          Result := 'RL ' + sX ;
        12 :
          Result := 'RR ' + sX ;
        6 :
          Result := 'SL0 ' + sX ;
        7 :
          Result := 'SL1 ' + sX ;
        0 :
          Result := 'SLA ' + sX ;
        4 :
          Result := 'SLX ' + sX ;
        14 :
          Result := 'SR0 ' + sX ;
        15 :
          Result := 'SR1 ' + sX ;
        8 :
          Result := 'SRA ' + sX ;
        10 :
          Result := 'SRX ' + sX ;
      else
        Result := '?? ' + HexFormat( aLen, aArg, aMask ) ;
      end ;

    $21000 .. $21FFF :
      Result := 'MOVE ' + sX + ', ' + sY ;
    $22000 .. $22FFF :
      Result := 'MOVE ' + sX + ', ' + kk ;
    $23000 .. $23FFF :
      Result := 'MOVE ' + sX + ', ' + sY ;
    $24000 .. $24FFF :
      Result := 'IN ' + sX + ', ' + kk ;
    $25000 .. $25FFF :
      Result := 'IN ' + sX + ', ' + sY ;
    $26000 .. $26FFF :
      Result := 'LD ' + sX + ', ' + kk ;
    $27000 .. $27FFF :
      Result := 'LD ' + sX + ', ' + sY ;

    $2A000 :
      Result := 'RET ' ;
    $2B000, $2B400, $2B800, $2BC00 :
      Result := 'RET ' + Cond ;

    $2C000 .. $2CFFF :
      Result := 'OUT ' + sX + ', ' + kk ;
    $2D000 .. $2DFFF :
      Result := 'OUT ' + sX + ', ' + sY ;
    $2E000 .. $2EFFF :
      Result := 'ST ' + sX + ', ' + kk ;
    $2F000 .. $2FFFF :
      Result := 'ST ' + sX + ', ' + sY ;

    $30000 .. $30FFF :
      Result := 'CALL ' + Loc ;
    $31000 .. $31FFF :
      Result := 'CALL ' + Cond + ', ' + Loc ;
    $34000 .. $34FFF :
      Result := 'JUMP ' + Loc ;
    $35000 .. $35FFF :
      Result := 'JUMP ' + Cond + ', ' + Loc ;

    $38000 :
      Result := 'RETI DISABLE' ;
    $38001 :
      Result := 'RETI ENABLE' ;
    $3C000 :
      Result := 'DINT' ;
    $3C001 :
      Result := 'EINT' ;
  else
    Result := '?? ' + HexFormat( aLen, aArg, aMask ) ;
  end ;
end ;

function PB6Format( const aLen : integer ; const aArg, aMask : uint64 ) : string ;
  function sX : string ;
  begin
    Result := Format( 's%X', [ ( aArg shr 8 ) and 15 ] ) ;
  end ;

  function sY : string ;
  begin
    Result := Format( 's%X', [ ( aArg shr 4 ) and 15 ] ) ;
  end ;

  function kk : string ;
  begin
    Result := Format( '0x%.02X', [ aArg and 255 ] ) ;
  end ;

  function Loc : string ;
  begin
    Result := Format( '0x%.03X', [ aArg and 4095 ] ) ;
  end ;

  function Cond : string ;
  begin
    case ( aArg shr 12 ) and 3 of
      0 :
        Result := 'Z' ;
      1 :
        Result := 'NZ' ;
      2 :
        Result := 'C' ;
      3 :
        Result := 'NC' ;
    else
      Result := '??' ;
    end ;
  end ;

begin
  case aArg of
    $00000 .. $00FFF :
      Result := 'MOVE ' + sX + ', ' + sY ;
    $01000 .. $01FFF :
      Result := 'MOVE ' + sX + ', ' + kk ;
    $08000 .. $08FFF :
      Result := 'IN ' + sX + ', ' + sY ;
    $09000 .. $09FFF :
      Result := 'IN ' + sX + ', ' + kk ;
    $0A000 .. $0AFFF :
      Result := 'LD ' + sX + ', ' + sY ;
    $0B000 .. $0BFFF :
      Result := 'LD ' + sX + ', ' + kk ;

    $2B000 .. $2BFFF :
      Result := 'OUTK ' + sX + ', ' + kk ;

    $2C000 .. $2CFFF :
      Result := 'OUT ' + sX + ', ' + sY ;
    $2D000 .. $2DFFF :
      Result := 'OUT ' + sX + ', ' + kk ;
    $2E000 .. $2EFFF :
      Result := 'ST ' + sX + ', ' + sY ;
    $2F000 .. $2FFFF :
      Result := 'ST ' + sX + ', ' + kk ;

    $02000 .. $02FFF :
      Result := 'AND ' + sX + ', ' + sY ;
    $03000 .. $03FFF :
      Result := 'AND ' + sX + ', ' + kk ;
    $04000 .. $04FFF :
      Result := 'OR ' + sX + ', ' + sY ;
    $05000 .. $05FFF :
      Result := 'OR ' + sX + ', ' + kk ;
    $06000 .. $06FFF :
      Result := 'XOR ' + sX + ', ' + sY ;
    $07000 .. $07FFF :
      Result := 'XOR ' + sX + ', ' + kk ;

    $0C000 .. $0CFFF :
      Result := 'TEST ' + sX + ', ' + sY ;
    $0D000 .. $0DFFF :
      Result := 'TEST ' + sX + ', ' + kk ;
    $0E000 .. $0EFFF :
      Result := 'TSTC ' + sX + ', ' + sY ;
    $0F000 .. $0FFFF :
      Result := 'TSTC ' + sX + ', ' + kk ;
    $1C000 .. $1CFFF :
      Result := 'COMP' + sX + ', ' + sY ;
    $1D000 .. $1DFFF :
      Result := 'COMP ' + sX + ', ' + kk ;
    $1E000 .. $1EFFF :
      Result := 'CMPC' + sX + ', ' + sY ;
    $1F000 .. $1FFFF :
      Result := 'CMPC ' + sX + ', ' + kk ;

    $16000 .. $16FFF :
      Result := 'STAR' + sX + ', ' + sY ;

    $10000 .. $10FFF :
      Result := 'ADD ' + sX + ', ' + sY ;
    $11000 .. $11FFF :
      Result := 'ADD ' + sX + ', ' + kk ;
    $12000 .. $12FFF :
      Result := 'ADDC ' + sX + ', ' + sY ;
    $13000 .. $13FFF :
      Result := 'ADDC ' + sX + ', ' + kk ;
    $18000 .. $18FFF :
      Result := 'SUB ' + sX + ', ' + sY ;
    $19000 .. $19FFF :
      Result := 'SUB ' + sX + ', ' + kk ;
    $1A000 .. $1AFFF :
      Result := 'SUBC ' + sX + ', ' + sY ;
    $1B000 .. $1BFFF :
      Result := 'SUBC ' + sX + ', ' + kk ;

    $14000 .. $14FFF :
      case aArg and 255 of
        2 :
          Result := 'RL ' + sX ;
        12 :
          Result := 'RR ' + sX ;
        6 :
          Result := 'SL0 ' + sX ;
        7 :
          Result := 'SL1 ' + sX ;
        0 :
          Result := 'SLA ' + sX ;
        4 :
          Result := 'SLX ' + sX ;
        14 :
          Result := 'SR0 ' + sX ;
        15 :
          Result := 'SR1 ' + sX ;
        8 :
          Result := 'SRA ' + sX ;
        10 :
          Result := 'SRX ' + sX ;
      else
        Result := '?? ' + HexFormat( aLen, aArg, aMask ) ;
      end ;

    $25000 :
      Result := 'RET ' ;
    $31000, $35000, $39000, $3D000 :
      Result := 'RET ' + Cond ;
    $21000 :
      Result := 'RET ' + sX + ', ' + kk ;

    $20000 .. $20FFF :
      Result := 'CALL ' + Loc ;
    $30000 .. $30FFF, $34000 .. $34FFF, $38000 .. $38FFF, $3C000 .. $3CFFF :
      Result := 'CALL ' + Cond + ', ' + Loc ;

    $22000 .. $22FFF :
      Result := 'JUMP ' + Loc ;
    $32000 .. $32FFF, $36000 .. $36FFF, $3A000 .. $3AFFF, $3E000 .. $3EFFF :
      Result := 'JUMP ' + Cond + ', ' + Loc ;

    $37000 .. $37000 :
      Result := 'BANK ' + 'A' ;
    $37001 .. $37001 :
      Result := 'BANK ' + 'B' ;

    $28000 :
      Result := 'DINT' ;
    $28001 :
      Result := 'EINT' ;
    $29000 :
      Result := 'RETI DISABLE' ;
    $29001 :
      Result := 'RETI ENABLE' ;
  else
    Result := '?? ' + HexFormat( aLen, aArg, aMask ) ;
  end ;
end ;

function Geti32( b : array of byte ; offset : integer ) : int32 ;
var
  i : integer ;
begin
  Result := 0 ;
  if gReader.fWord_be then begin
    for i := 0 to 3 do begin
      Result := Result shl 8 ;
      Result := Result or b[ i + offset ] ;
    end ;
  end
  else begin
    for i := 3 downto 0 do begin
      Result := Result shl 8 ;
      Result := Result or b[ i + offset ] ;
    end ;
  end ;
end ;

function Geti64( b : array of byte ; offset : integer ) : int64 ;
var
  i : integer ;
begin
  Result := 0 ;
  if gReader.fWord_be then begin
    for i := 0 to 7 do begin
      Result := Result shl 8 ;
      Result := Result or b[ i + offset ] ;
    end ;
  end
  else begin
    for i := 7 downto 0 do begin
      Result := Result shl 8 ;
      Result := Result or b[ i + offset ] ;
    end ;
  end ;
end ;

function TGHWReader.GetNbrSignals : uint32 ;
begin
  Result := fSignals.Count ;
end ;

function TGHWReader.GetNbrStrings : uint32 ;
begin
  Result := fStrings.Count ;
end ;

function TGHWReader.GetNbrTypes : uint32 ;
begin
  Result := fTypes.Count ;
end ;

function TGHWReader.GetSignals( index : integer ) : TGHWSignal ;
begin
  Result := nil ;
  if index < fSignals.Count then
    Result := fSignals[ index ] as TGHWSignal ;
end ;

function TGHWReader.GetStrings( index : integer ) : string ;
begin
  Result := '' ;
  if index < fStrings.Count then
    Result := fStrings[ index ] ;
end ;

function TGHWReader.GetTypes( index : integer ) : TGHWType ;
begin
  Result := fTypes[ index ] as TGHWType ;
end ;

function TGHWReader.KindToString( aKind : ghdl_rtik_t ) : string ;
const
  KindNames : array [ ghdl_rtik_t ] of string = ( //
    'ghdl_rtik_top', 'ghdl_rtik_library', 'ghdl_rtik_package', 'ghdl_rtik_package_body', //
    'ghdl_rtik_entity', 'ghdl_rtik_architecture', 'ghdl_rtik_process', 'ghdl_rtik_block', //
    'ghdl_rtik_if_generate', 'ghdl_rtik_for_generate', 'ghdl_rtik_instance', 'ghdl_rtik_constant',
    //
    'ghdl_rtik_iterator', 'ghdl_rtik_variable', 'ghdl_rtik_signal', 'ghdl_rtik_file', //
    'ghdl_rtik_port', 'ghdl_rtik_generic', 'ghdl_rtik_alias', 'ghdl_rtik_guard', //
    'ghdl_rtik_component', 'ghdl_rtik_attribute', //

    'ghdl_rtik_type_b2', 'ghdl_rtik_type_e8', 'ghdl_rtik_type_e32', 'ghdl_rtik_type_i32', //
    'ghdl_rtik_type_i64', 'ghdl_rtik_type_f64', 'ghdl_rtik_type_p32', 'ghdl_rtik_type_p64', //

    'ghdl_rtik_type_access', 'ghdl_rtik_type_array', 'ghdl_rtik_type_record', 'ghdl_rtik_type_file',
    //
    'ghdl_rtik_subtype_scalar', 'ghdl_rtik_subtype_array', 'ghdl_rtik_subtype_array_ptr', //
    'ghdl_rtik_subtype_unconstrained_array', 'ghdl_rtik_subtype_record', 'ghdl_rtik_subtype_access',
    //
    'ghdl_rtik_type_protected', 'ghdl_rtik_element', 'ghdl_rtik_unit', 'ghdl_rtik', //
    'ghdl_rtik_attribute_quiet', 'ghdl_rtik_attribute_stable', 'ghdl_rtik_error' ) ;
begin
  Result := KindNames[ aKind ] ;
end ;

function TGHWReader.Open( aFilename : string ) : boolean ;
const
  magic : ansistring = 'GHDLwave'#10 ;
var
  hdr : array [ 0 .. 15 ] of byte ;
  i : integer ;
begin
  Result := true ;
  if not TGHWLib.Open( aFilename ) then
    Exit( false ) ;
  fFilename := aFilename ;
  TGHWLib.ReadBytes( hdr, sizeof( hdr ) ) ;

  // Check magic
  for i := 0 to 8 do
    assert( hdr[ i ] = Ord( magic[ i + 1 ] ), 'Open: magic?' ) ;

  // Check version
  assert( ( hdr[ 9 ] = 16 ) and ( hdr[ 10 ] = 0 ), 'Open: version?' ) ;

  fVersion := hdr[ 11 ] ;
  assert( fVersion = 1, 'Open: version/=1' ) ;

  if hdr[ 12 ] = 1 then
    fWord_be := false
  else if hdr[ 12 ] = 2 then
    fWord_be := true
  else
    assert( false, 'Open: endianess?' ) ;

  fWord_len := hdr[ 13 ] ;
  fOff_len := hdr[ 14 ] ;

  assert( hdr[ 15 ] = 0, 'Open: hdr[15]/=0' ) ;

  fHie := nil ;
end ;

function TGHWReader.Opened : boolean ;
begin
  Result := TGHWLib.Opened ;
end ;

function TGHWReader.ReadSection( out aProc : TGHWLibProc ) : integer ;
type
  TGHWSection = record
    name : string ;
    func : TGHWLibProc ;
  end ;

const
  ghw_sections : array [ 0 .. 9 ] of TGHWSection = ( //
    ( name : #0#0#0 ; func : nil ), //
    ( name : 'STR' ; func : TGHWLib.ReadStrings ), //
    ( name : 'HIE' ; func : TGHWLib.ReadHie ), //
    ( name : 'TYP' ; func : TGHWLib.ReadTypes ), //
    ( name : 'WKT' ; func : TGHWLib.ReadWellKnownTypes ), //
    ( name : 'EOH' ; func : TGHWLib.ReadEOH ), //
    ( name : 'SNP' ; func : TGHWLib.ReadSnapshot ), //
    ( name : 'CYC' ; func : TGHWLib.ReadCycles ), //
    ( name : 'DIR' ; func : TGHWLib.ReadDirectory ), //
    ( name : 'TAI' ; func : TGHWLib.ReadTailer ) //
    ) ;

var
  hdr : array [ 0 .. 3 ] of byte ;
  i, j : integer ;
  iProc : TGHWLibProc ;

label
  outer ;
begin
  Result := -1 ;
  aProc := nil ;
  if TGHWLib.EOF then
    Exit( -1 ) ;
  TGHWLib.ReadBytes( hdr, sizeof( hdr ) ) ;

  for i := low( ghw_sections ) to high( ghw_sections ) do begin
    for j := 0 to 2 do
      if hdr[ j ] <> Ord( ghw_sections[ i ].name[ j + 1 ] ) then
        goto outer ;

    if hdr[ 3 ] = 0 then begin
      iProc := ghw_sections[ i ].func ;
      assert( assigned( iProc ), Format( 'ReadSection: unknown section: %s', [ string( hdr ) ] ) ) ;
      aProc := iProc ;
      Exit( 0 ) ;
    end ;
  outer :
  end ;
end ;

procedure TGHWReader.ReadSections ;
var
  iProc : TGHWLibProc ;
begin
  while gReader.ReadSection( iProc ) >= 0 do
    iProc ;
  if assigned( fHie ) then begin
    fHie.name := fFilename ;
    fHie.Newest := SnapTime ;
  end ;
end ;

procedure TGHWReader.SetNbrStrings( const Value : uint32 ) ;
begin
  fSignals.Count := Value ;
end ;

procedure TGHWReader.SetSignals( index : integer ; const Value : TGHWSignal ) ;
begin
  fSignals[ index ] := Value ;
end ;

procedure TGHWReader.SetSnapTime( const Value : int64 ) ;
begin
  fSnaptime := Value ;
end ;

procedure TGHWReader.AddString( s : string ) ;
begin
  fStrings.Add( s ) ;
end ;

procedure TGHWReader.AddTime( delta : int64 ) ;
begin
  fSnaptime := fSnaptime + delta ;
end ;

procedure TGHWReader.AddType( t : TGHWType ) ;
begin
  fTypes.Add( t ) ;
end ;

procedure TGHWReader.Clear ;
begin
  fHie := nil ;
  TGHWHie.Clear ;
  TGHWRange.Clear ;
  TGHWSignal.Clear ;
  fTypes.Clear ;
  fStrings.Clear ;
  fSignals.Clear ;
end ;

procedure TGHWReader.Close ;
begin
  TGHWLib.Close ;
end ;

constructor TGHWReader.Create ;
begin
  inherited ;
  fTypes := TObjectlist.Create ;
  fSignals := TObjectlist.Create ;
  fStrings := TStringList.Create ;
end ;

destructor TGHWReader.Destroy ;
begin
  fStrings.Free ;
  fSignals.Free ;
  fTypes.Free ;
  TGHWHie.Clear ;
  TGHWRange.Clear ;
  TGHWSignal.Clear ;
  inherited ;
end ;

function TGHWReader.FileExists( aFilename : string ) : boolean ;
begin
  Result := TGHWLib.FileExists( aFilename ) ;
end ;

{ TGHWLib }

class procedure TGHWLib.ReadHie ;
var
  hdr : array [ 0 .. 15 ] of byte ;
  iBlock : TGHWHie ;
  last : PGHWHie ;
  iHie : TGHWHie ;
  link : TGHWHie ;
  iTyp : TGHWType ;
  iSig : TGHWSignal ;
  t : byte ;
  u32 : uint32 ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;

  assert( ( hdr[ 0 ] = 0 ) and ( hdr[ 1 ] = 0 ) and ( hdr[ 2 ] = 0 ) and ( hdr[ 3 ] = 0 ), //
    'Hie.Read: header not zero' ) ;
  gReader.nbr_scopes := Geti32( hdr, 4 ) ;
  gReader.nbr_sigs := Geti32( hdr, 8 ) ;
  gReader.nbr_basic_sigs := Geti32( hdr, 12 ) ;

  iBlock := TGHWHie.Factory( ghw_hie_design ) ;
  gReader.fHie := iBlock ;
  iBlock.Kind := ghw_hie_design ;
  iBlock.name := 'root' ;
  iBlock.fParent := nil ;
  iBlock.fBrother := nil ;
  iBlock.fBlock.Child := nil ;

  last := @iBlock.fBlock.Child ;

  // allocate empty signals
  inc( gReader.nbr_basic_sigs ) ;
  gReader.NbrStrings := gReader.nbr_basic_sigs ;

  while true do begin
    ReadByte( t ) ;
    if t = 0 then
      break ;

    if ghw_hie_kind_t( t ) = ghw_hie_eos then begin
      iBlock := iBlock.fParent as TGHWHie ;
      if iBlock.fBlock.Child = nil then
        last := @iBlock.fBlock.Child
      else begin
        link := iBlock.fBlock.Child ;
        while link.fBrother <> nil do
          link := link.fBrother ;
        last := @link.fBrother ;
      end ;
      Continue ;
    end ;

    iHie := TGHWHie.Factory( ghw_hie_kind_t( t ) ) ;
    iHie.fParent := iBlock ;
    iHie.fBrother := nil ;

    last^ := iHie ; // link
    last := @iHie.Brother ;
    ReadULEB128( u32 ) ;
    iHie.name := gReader.Strings[ u32 ] ;

    case ghw_hie_kind_t( t ) of

      ghw_hie_eoh, ghw_hie_design, ghw_hie_eos :
        assert( false, 'TGHWHie.Read: Should not be here' ) ;

      // no substructures
      ghw_hie_process :
        ;

      // block hierarchy
      ghw_hie_block, ghw_hie_generate_if, ghw_hie_generate_for, ghw_hie_instance, //
        ghw_hie_generic, ghw_hie_package : begin
          iHie.fBlock.Child := nil ;
          if ghw_hie_kind_t( t ) = ghw_hie_generate_for then begin
            ReadTypeID( iTyp ) ;
            iHie.fBlock.iter_type := iTyp ;
            ReadValue( iHie.fBlock.iter_type, iHie.fBlock.iter_value ) ;
          end ;
          iBlock := iHie ;
          last := @iHie.fBlock.Child ;
        end ;

      // signals and ports
      ghw_hie_signal, //
        ghw_hie_port_in, ghw_hie_port_out, ghw_hie_port_inout, ghw_hie_port_buffer, ghw_hie_port_linkage : //
        begin
          ReadTypeID( iTyp ) ;
          iHie.SignalType := iTyp ;
          ReadSignal( iTyp, iSig ) ;
          iSig.Parent := iHie ;
          iHie.Signals := iSig ;
        end ;
    else
      assert( false, Format( 'TGHW.ReadHie: unhandled kind "%d"', [ t ] ) ) ;
    end ;
  end ;
end ;

class procedure TGHWLib.ReadStrings ;
var
  hdr : array [ 0 .. 11 ] of byte ;
  term : string ;
  i, sh, len : integer ;
  c : ansichar ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;

  assert( ( hdr[ 0 ] = 0 ) and ( hdr[ 1 ] = 0 ) and ( hdr[ 2 ] = 0 ) and ( hdr[ 3 ] = 0 ),
    'String.Read: header not zero' ) ;

  gReader.nbr_str := Geti32( hdr, 4 ) ;
  inc( gReader.nbr_str ) ;

  gReader.fStrings.Clear ;
  gReader.AddString( '<anon>' ) ;

  len := 0 ;
  for i := 1 to gReader.nbr_str - 1 do begin
    term := gReader.Strings[ i - 1 ] ;
    Setlength( term, len ) ;
    while true do begin
      ReadChar( c ) ;
      if c in [ #0 .. #31, #128 .. #159 ] then
        break ;
      term := term + char( c ) ;
    end ;
    gReader.AddString( string( term ) ) ;

    len := Ord( c ) and $1F ;
    sh := 5 ;
    while Ord( c ) >= 128 do begin
      ReadChar( c ) ;
      len := len or ( ( Ord( c ) and $1F ) shl sh ) ;
      inc( sh, 5 ) ;
    end ;
  end ;
  ReadBytes( hdr, 4 ) ;
  assert( ( hdr[ 0 ] = Ord( 'E' ) ) and ( hdr[ 1 ] = Ord( 'O' ) ) and ( hdr[ 2 ] = Ord( 'S' ) ) and ( hdr[ 3 ] = 0 ),
    'String.Read: no EOS' ) ;
end ;

{ TGHW }

constructor TGHW.Create ;
begin
  fName := ClassName ;
end ;

function TGHW.GetDisplayName : string ;
begin
  Result := ClassName ;
end ;

function TGHW.GetHint( index : integer ) : string ;
begin
  Result := '' ;
  case index of
    1 :
      Result := 'column1' ;
    2 :
      Result := 'column2' ;
  end ;
end ;

function TGHW.GetNbrOfElem : integer ;
begin
  Result := 1 ;
end ;

function TGHW.HintAt( aTime : int64 ) : string ;
begin
  Result := '<>' ;
end ;

procedure TGHW.SetName( const Value : string ) ;
begin
  fName := Value ;
end ;

procedure TGHW.SetNbrOfElem( aValue : integer ) ;
begin
end ;

procedure TGHW.SetParent( const Value : TGHW ) ;
begin
  fParent := Value ;
end ;

{ TGHWType }

function TGHWType.GetBasetype : TGHWType ;
begin
  Result := Self ;
end ;

function TGHWType.GetChoices : TGHWFormatChoices ;
begin
  Result := [ fmtNone ] ;
end ;

function TGHWType.GetFormat : TGHWValueFormat ;
begin
  Result := fmtNone ;
end ;

procedure TGHWType.SetBaseType( const Value : TGHWType ) ;
begin
end ;

procedure TGHWType.SetKind( const Value : ghdl_rtik_t ) ;
begin
  fKind := Value ;
end ;

function TGHWType.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
begin
  Result := '?' ;
end ;

function TGHWType.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := '?' ;
end ;

class procedure TGHWLib.ReadTypes ;
var
  hdr : array [ 0 .. 7 ] of byte ;
  i, j, k : integer ;
  t : byte ;
  str : string ;
  i32 : int32 ;
  u32 : uint32 ;
  i64 : int64 ;
  b : byte ;
  nbr_el : integer ;

  base : TGHWType ;
  Range : TGHWRange ;
  typeenum : TGHWTypeEnum ;
  typescalar : TGHWTypeScalar ;
  typephysical : TGHWTypePhysical ;
  subtypescalar : TGHWSubTypeScalar ;
  aunit : TGHWUnit ;
  typearray : TGHWTypeArray ;
  subtypearray : TGHWSubTypeArray ;
  typerecord : TGHWTypeRecord ;
  recordelement : TGHWRecordElement ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;
  assert( ( hdr[ 0 ] = 0 ) and ( hdr[ 1 ] = 0 ) and ( hdr[ 2 ] = 0 ) and ( hdr[ 3 ] = 0 ), 'Type.Read: EOF?' ) ;

  gReader.nbr_types := Geti32( hdr, 4 ) ;

  for i := 0 to gReader.nbr_types - 1 do begin
    ReadByte( t ) ;

    case ghdl_rtik_t( t ) of
      ghdl_rtik_type_b2, ghdl_rtik_type_e8 : begin
          typeenum := TGHWTypeEnum.Create ;
          gReader.AddType( typeenum ) ;
          typeenum.Kind := ghdl_rtik_t( t ) ;
          typeenum.WKT := ghw_wkt_unknown ;
          ReadStrID( str ) ;
          typeenum.name := str ;

          ReadULEB128( u32 ) ;
          typeenum.NbrOfElem := u32 ;
          for j := 0 to u32 - 1 do begin
            ReadStrID( str ) ;
            typeenum.Literals[ j ] := str ;
          end ;
        end ;

      ghdl_rtik_type_i32, ghdl_rtik_type_i64, ghdl_rtik_type_f64 : begin
          typescalar := TGHWTypeScalar.Create ;
          gReader.AddType( typescalar ) ;
          typescalar.Kind := ghdl_rtik_t( t ) ;
          ReadStrID( str ) ;
          typescalar.name := str ;
        end ;

      ghdl_rtik_type_p32, ghdl_rtik_type_p64 : begin
          typephysical := TGHWTypePhysical.Create ;
          gReader.AddType( typephysical ) ;
          typephysical.Kind := ghdl_rtik_t( t ) ;
          ReadStrID( str ) ;
          typephysical.name := str ;

          if gReader.fVersion = 0 then
            typephysical.NbrOfElem := 0
          else begin
            ReadULEB128( u32 ) ;
            typephysical.NbrOfElem := u32 ;
            for k := 0 to typephysical.NbrOfElem - 1 do begin
              ReadStrID( str ) ;
              aunit.name := str ;
              case ghdl_rtik_t( t ) of
                ghdl_rtik_type_p32 : begin
                    ReadSLEB128( i32 ) ;
                    aunit.Value := u32 ;
                  end ;
                ghdl_rtik_type_p64 : begin
                    ReadLSLEB128( i64 ) ;
                    aunit.Value := i64 ;
                  end ;
              end ;
              typephysical.Units[ k ] := aunit ;
            end ;
          end ;
        end ;

      ghdl_rtik_subtype_scalar : begin
          subtypescalar := TGHWSubTypeScalar.Create ;
          gReader.AddType( subtypescalar ) ;
          subtypescalar.Kind := ghdl_rtik_t( t ) ;
          ReadStrID( str ) ;
          subtypescalar.name := str ;

          ReadTypeID( base ) ;
          subtypescalar.BaseType := base ;

          ReadRange( Range ) ;
          subtypescalar.Range := Range ;
        end ;

      ghdl_rtik_type_array : begin
          typearray := TGHWTypeArray.Create ;
          gReader.AddType( typearray ) ;
          typearray.Kind := ghdl_rtik_t( t ) ;
          ReadStrID( str ) ;
          typearray.name := str ;

          ReadTypeID( base ) ;
          typearray.ElementType := base ;
          ReadULEB128( u32 ) ;
          typearray.NbrOfElem := u32 ;
          for k := 0 to u32 - 1 do begin
            ReadTypeID( base ) ;
            typearray.Dims[ k ] := base ;
          end ;
        end ;

      ghdl_rtik_subtype_array, ghdl_rtik_subtype_array_ptr : begin
          subtypearray := TGHWSubTypeArray.Create ;
          gReader.AddType( subtypearray ) ;
          subtypearray.Kind := ghdl_rtik_t( t ) ;
          ReadStrID( str ) ;
          subtypearray.name := str ;

          ReadTypeID( TGHWType( typearray ) ) ;
          subtypearray.BaseType := typearray ;

          nbr_el := typearray.NbrOfElem ;
          subtypearray.NbrOfRanges := typearray.NbrOfElem ;

          for k := 0 to subtypearray.NbrOfRanges - 1 do begin
            ReadRange( Range ) ;
            subtypearray.Ranges[ k ] := Range ;
            nbr_el := nbr_el * Range.Length ;
          end ;
          subtypearray.NbrOfElem := nbr_el ;
        end ;

      ghdl_rtik_type_record : begin
          typerecord := TGHWTypeRecord.Create ;
          gReader.AddType( typerecord ) ;
          typerecord.Kind := ghdl_rtik_t( t ) ;
          ReadStrID( str ) ;
          typerecord.name := str ;
          ReadULEB128( u32 ) ;
          typerecord.NbrOfElem := u32 ;

          for k := 0 to typerecord.NbrOfElem - 1 do begin
            ReadStrID( str ) ;
            recordelement.name := str ;
            ReadTypeID( base ) ;
            recordelement.typ := base ;
            typerecord.RecElems[ k ] := recordelement ;
          end ;
        end ;

    else
      assert( false, Format( 'Type.Read: unhandled type: %s', //
        [ gReader.KindToString( ghdl_rtik_t( t ) ) ] ) ) ;
    end ;
  end ;
  ReadByte( b ) ;
  assert( b = 0, 'Type.Read: termiation not 0' ) ;
  assert( gReader.NbrTypes = gReader.nbr_types, 'Type.Read: # of types mismatch' ) ;
end ;

class procedure TGHWLib.ReadSnapshot ;
var
  hdr : array [ 0 .. 11 ] of byte ;
  iSig : TGHWSignal ;
  i : integer ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;
  assert( ( hdr[ 0 ] = 0 ) and ( hdr[ 1 ] = 0 ) and ( hdr[ 2 ] = 0 ) and ( hdr[ 3 ] = 0 ),
    'Snapshot.Read: header<>0' ) ;

  gReader.SnapTime := Geti64( hdr, 4 ) ;

  with gReader do
    for i := 0 to fSignals.Count - 1 do
      if assigned( fSignals[ i ] ) then begin
        iSig := fSignals[ i ] as TGHWSignal ;
        assert( assigned( iSig.SignalType ), 'Snapshot.Read: Type?' ) ;
        iSig.ReadCycle( gReader.SnapTime ) ;
      end ;

  ReadBytes( hdr, 4 ) ;
  assert( ( hdr[ 0 ] = Ord( 'E' ) ) and ( hdr[ 1 ] = Ord( 'S' ) ) and ( hdr[ 2 ] = Ord( 'N' ) ) and ( hdr[ 3 ] = 0 ),
    'Snapshot.Read: no ESN' ) ;
end ;

class procedure TGHWLib.ReadWellKnownTypes ;
var
  hdr : array [ 0 .. 3 ] of byte ;
  t : byte ;
  tid : TGHWType ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;
  assert( ( hdr[ 0 ] = 0 ) and ( hdr[ 1 ] = 0 ) and ( hdr[ 2 ] = 0 ) and ( hdr[ 3 ] = 0 ),
    'WellKnownTypes.Read: header<>0' ) ;

  while true do begin
    ReadByte( t ) ;
    if t = 0 then
      break ;
    ReadTypeID( tid ) ;
    if ( tid.Kind = ghdl_rtik_type_b2 ) or ( tid.Kind = ghdl_rtik_type_e8 ) then begin //
      gName := tid.ClassName ; //
      ( tid as TGHWTypeEnum ).WKT := ghw_wkt_type_t( t ) ;
    end ;
  end ;
end ;

class procedure TGHWLib.ReadEOH ;
begin
end ;

class procedure TGHWLib.ReadDirectory ;
var
  hdr : array [ 0 .. 7 ] of byte ;
  nbr_entries : integer ;
  i : integer ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;
  nbr_entries := Geti32( hdr, 4 ) ;
  for i := 0 to nbr_entries - 1 do begin
    ReadBytes( hdr, sizeof( hdr ) ) ;
  end ;
  ReadBytes( hdr, 4 ) ;
  assert( ( hdr[ 0 ] = Ord( 'E' ) ) and ( hdr[ 1 ] = Ord( 'O' ) ) and ( hdr[ 2 ] = Ord( 'D' ) ) and ( hdr[ 3 ] = 0 ),
    'Directory.Read: no EOD' ) ;
end ;

class procedure TGHWLib.ReadTailer ;
var
  hdr : array [ 0 .. 7 ] of byte ;
  // pos : uint32 ;
begin
  ReadBytes( hdr, sizeof( hdr ) ) ;
  // pos := Geti32( hdr, 4 ) ;
end ;

class procedure TGHWLib.ReadCycles ;
var
  hdr : array [ 0 .. 7 ] of byte ;
  index : uint32 ;
  offset : uint32 ;
  delta : int64 ;
  iSig : TGHWSignal ;
  iCount : uint32 ;

begin
  ReadBytes( hdr, sizeof( hdr ) ) ;
  gReader.SnapTime := Geti64( hdr, 0 ) ;

  delta := 0 ;
  repeat
    gReader.AddTime( delta ) ;
    iCount := gReader.NbrSignals ;
    index := 0 ;
    while true do begin
      // Read offset to next signal
      ReadULEB128( offset ) ;
      if offset = 0 then
        break ;
      inc( index, offset ) ;
      // while offset > 0 do begin
      // inc( index ) ;
      // if assigned( gSignals[ index ] ) then begin
      // iSig := TGHWSignal( gSignals[ index ] ) ;
      // assert( assigned( iSig.SignalType ), Format( 'TGHWCycle.Read i=%d, Type?', [ index ] ) ) ;
      // dec( offset ) ;
      // end ;
      // end ;
      assert( index < iCount, Format( 'TGHWCycle.Read i=%d', [ index ] ) ) ;
      iSig := TGHWSignal( gReader.Signals[ index ] ) ;
      iSig.ReadCycle( gReader.SnapTime ) ;
    end ;

    ReadLSLEB128( delta ) ;
  until delta < 0 ;

  ReadBytes( hdr, 4 ) ;
  assert( ( hdr[ 0 ] = Ord( 'E' ) ) and ( hdr[ 1 ] = Ord( 'C' ) ) and ( hdr[ 2 ] = Ord( 'Y' ) ) and ( hdr[ 3 ] = 0 ),
    'TGHWCycle.Read: header<>0' ) ;
end ;

class procedure TGHWLib.ReadRange( out aRes : TGHWRange ) ;
var
  t : byte ;
  b : byte ;
  i32 : int32 ;
  i64 : int64 ;
  f64 : double ;
  Range : TGHWRange ;
begin
  aRes := nil ;

  ReadByte( t ) ;

  case ghdl_rtik_t( t and $7F ) of
    ghdl_rtik_type_b2, ghdl_rtik_type_e8 : begin
        Range := TGHWRange.Factory ;
        Range.Kind := ghdl_rtik_t( t and $7F ) ;
        Range.Dir := ( t and $80 ) <> 0 ;
        ReadByte( b ) ;
        Range.Left := b ;
        ReadByte( b ) ;
        Range.Right := b ;
        aRes := Range ;
      end ;

    ghdl_rtik_type_i32, ghdl_rtik_type_p32 : begin
        Range := TGHWRange.Factory ;
        Range.Kind := ghdl_rtik_t( t and $7F ) ;
        Range.Dir := ( t and $80 ) <> 0 ;
        ReadSLEB128( i32 ) ;
        Range.Left := i32 ;
        ReadSLEB128( i32 ) ;
        Range.Right := i32 ;
        aRes := Range ;
      end ;

    ghdl_rtik_type_i64, ghdl_rtik_type_p64 : begin
        Range := TGHWRange.Factory ;
        Range.Kind := ghdl_rtik_t( t and $7F ) ;
        Range.Dir := ( t and $80 ) <> 0 ;
        ReadLSLEB128( i64 ) ;
        Range.Left := i64 ;
        ReadLSLEB128( i64 ) ;
        Range.Right := i64 ;
        aRes := Range ;
      end ;

    ghdl_rtik_type_f64 : begin
        Range := TGHWRange.Factory ;
        Range.Kind := ghdl_rtik_t( t and $7F ) ;
        Range.Dir := ( t and $80 ) <> 0 ;
        ReadF64( f64 ) ;
        Range.Left := f64 ;
        ReadF64( f64 ) ;
        Range.Right := f64 ;
        aRes := Range ;
      end ;

  else
    assert( true, 'ReadRange: unknown range' ) ;
  end ;
end ;

class function TGHWLib.ReadBytes( out aRes : array of byte ; aLen : integer ) : integer ;
var
  i, l : integer ;
begin
  Result := 0 ;
  l := Length( fStream ) ;
  assert( ( fIndex + aLen ) <= l, 'EOF?' ) ;

  for i := 0 to aLen - 1 do begin
    aRes[ i ] := fStream[ fIndex ] ;
    inc( fIndex ) ;
  end ;
end ;

class procedure TGHWLib.ReadChar( out aRes : ansichar ) ;
begin
  assert( ( fIndex + 1 ) < Length( fStream ), 'ReadChar: EOF?' ) ;
  aRes := ansichar( fStream[ fIndex ] ) ;
  inc( fIndex ) ;
end ;

class procedure TGHWLib.Close ;
begin
  fStream := nil ;
  fIndex := 0 ;
end ;

class function TGHWLib.EOF : boolean ;
begin
  Result := fIndex >= Length( fStream )
end ;

class function TGHWLib.FileExists( aFilename : string ) : boolean ;
begin
  Result := TFile.Exists( aFilename ) ;
end ;

class function TGHWLib.Open( aFilename : string ) : boolean ;
begin
  try
    fStream := TFile.ReadAllBytes( aFilename ) ;
    fIndex := 0 ;
    Result := Opened ;
  except
    on E : EInOutError do
      Result := false ;
  end ;
end ;

class function TGHWLib.Opened : boolean ;
begin
  Result := fStream <> nil ;
end ;

class procedure TGHWLib.ReadByte( out aRes : byte ) ;
begin
  assert( ( fIndex + 1 ) < Length( fStream ), 'ReadByte: EOF?' ) ;
  aRes := fStream[ fIndex ] ;
  inc( fIndex ) ;
end ;

class procedure TGHWLib.ReadStrID( out aRes : string ) ;
var
  id : uint32 ;
begin
  ReadULEB128( id ) ;
  assert( id < gReader.NbrStrings, //
    Format( 'ReadStrID: string index %d out of bound %d', [ id, gReader.NbrStrings ] ) ) ;
  aRes := gReader.Strings[ id ] ;
end ;

class procedure TGHWLib.ReadTypeID( out aRes : TGHWType ) ;
var
  id : uint32 ;
begin
  ReadULEB128( id ) ;
  gName := gReader.Types[ id - 1 ].ClassName ;
  aRes := gReader.Types[ id - 1 ] as TGHWType ;
end ;

class procedure TGHWLib.ReadF64( out aRes : double ) ;
begin
  // FIXME: handle byte order
  assert( ( fIndex + sizeof( aRes ) ) < Length( fStream ), 'ReadF64: EOF?' ) ;
  aRes := pDouble( @fStream[ fIndex ] )^ ;
  inc( fIndex, sizeof( aRes ) ) ;
end ;

class procedure TGHWLib.ReadLSLEB128( out aRes : int64 ) ;
const
  r_mask : int64 = -1 ;
var
  r : int64 ;
  off : uint32 ;
  v : uint8 ;
begin
  r := 0 ;
  off := 0 ;
  while true do begin
    ReadByte( v ) ;
    r := r or ( ( v and $7F ) shl off ) ;
    inc( off, 7 ) ;
    if ( v and $80 ) = 0 then begin
      if ( ( v and $40 ) <> 0 ) and ( off < 64 ) then
        r := r or ( r_mask shl off ) ;
      break ;
    end ;
  end ;
  aRes := r ;
end ;

class procedure TGHWLib.ReadSLEB128( out aRes : int32 ) ;
var
  r : int32 ;
  off : uint32 ;
  v : uint8 ;
begin
  r := 0 ;
  off := 0 ;
  while true do begin
    ReadByte( v ) ;
    r := r or ( int32( v and $7F ) shl off ) ;
    inc( off, 7 ) ;
    if ( v and $80 ) = 0 then begin
      if ( ( v and $40 ) <> 0 ) and ( off < 32 ) then
        r := r or int32( uint32( -1 ) shl off ) ;
      break ;
    end ;
  end ;
  aRes := r ;
end ;

class procedure TGHWLib.ReadULEB128( out aRes : uint32 ) ;
var
  r : uint32 ;
  off : uint32 ;
  v : uint8 ;
begin
  r := 0 ;
  off := 0 ;
  while true do begin
    ReadByte( v ) ;
    r := r or ( ( v and $7F ) shl off ) ;
    if ( v and $80 ) = 0 then
      break ;
    inc( off, 7 ) ;
  end ;
  aRes := r ;
end ;

// Read a signal composed of severals elements
class procedure TGHWLib.ReadSignal( const aType : TGHWType ; out aSig : TGHWSignal ) ;
var
  u32 : uint32 ;
  i : integer ;

  iSTA : TGHWSubTypeArray ;
  iTR : TGHWTypeRecord ;
  iSig : TGHWSignal ;
begin
  assert( assigned( aType ), 'ReadSignal: type not assigned' ) ;

  case aType.Kind of
    ghdl_rtik_type_b2, ghdl_rtik_type_e8, ghdl_rtik_type_e32, ghdl_rtik_subtype_scalar : begin
        ReadULEB128( u32 ) ;
        aSig := TGHWSignal.Factory( aType, u32 ) ;
      end ;

    ghdl_rtik_subtype_array, ghdl_rtik_subtype_array_ptr : begin
        iSTA := aType as TGHWSubTypeArray ;
        aSig := TGHWSignal.Factory( aType ) ;
        aSig.Count := iSTA.NbrOfElem ;

        for i := 0 to iSTA.NbrOfElem - 1 do begin
          ReadSignal( ( iSTA.BaseType as TGHWTypeArray ).ElementType, iSig ) ;
          iSig.name := IntToStr( iSTA.Ranges[ 0 ].IndexToRange( i ) ) ;
          iSig.Parent := aSig ;
          aSig[ i ] := iSig ;
        end ;
      end ;

    ghdl_rtik_type_record : begin
        iTR := aType as TGHWTypeRecord ;
        aSig := TGHWSignal.Factory( aType ) ;
        aSig.Count := iTR.NbrOfElem ;
        for i := 0 to iTR.NbrOfElem - 1 do begin
          ReadSignal( iTR.RecElems[ i ].typ, iSig ) ;
          iSig.name := iTR.RecElems[ i ].name ;
          iSig.Parent := aSig ;
          aSig[ i ] := iSig ;
        end ;
      end ;
  else
    assert( false, Format( 'ReadSignal: type kind ''%s'' unhandled', [ gReader.KindToString( aType.Kind ) ] ) ) ;
  end ;
end ;

class procedure TGHWLib.ReadValue( const aType : TGHWType ; out aRes : TGHWValue ) ;
var
  b : byte ;
  i32 : int32 ;
  i64 : int64 ;
  d : double ;
begin
  assert( assigned( aType ) ) ;
  assert( ( aType.BaseType <> nil ), 'ReadValue: Basetype?' ) ;

  case aType.BaseType.Kind of
    ghdl_rtik_type_b2 : begin
        ReadByte( b ) ;
        aRes.i64 := b ;
      end ;

    ghdl_rtik_type_e8 : begin
        ReadByte( b ) ;
        aRes.i64 := b ;
      end ;

    ghdl_rtik_type_i32, ghdl_rtik_type_p32 : begin
        ReadSLEB128( i32 ) ;
        aRes.i64 := i32 ;
      end ;

    ghdl_rtik_type_f64 : begin
        ReadF64( d ) ;
        aRes.f64 := d ;
      end ;

    ghdl_rtik_type_i64, ghdl_rtik_type_p64 : begin
        ReadLSLEB128( i64 ) ;
        aRes.i64 := i64 ;
      end ;

  else
    assert( false, Format( 'ReadValue: cannot handle format %d', [ Ord( aType.BaseType.Kind ) ] ) ) ;
  end ;
end ;

{ TGHWHie }

function TGHWHie.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

class procedure TGHWHie.Clear ;
begin
  FreeAndNil( fHierObjects ) ;
end ;

class function TGHWHie.Factory( aKind : ghw_hie_kind_t ) : TGHWHie ;
begin
  case aKind of
    ghw_hie_eoh :
      Result := TGHWHieEOH.Create ;
    ghw_hie_design :
      Result := TGHWHieDesign.Create ;
    ghw_hie_block :
      Result := TGHWHieBlock.Create ;
    ghw_hie_generate_if :
      Result := TGHWHieGenerateIf.Create ;
    ghw_hie_generate_for :
      Result := TGHWHieGenerateFor.Create ;
    ghw_hie_instance :
      Result := TGHWHieInstance.Create ;
    ghw_hie_package :
      Result := TGHWHiePackage.Create ;
    ghw_hie_process :
      Result := TGHWHieProcess.Create ;
    ghw_hie_generic :
      Result := TGHWHieGeneric.Create ;
    ghw_hie_eos :
      Result := TGHWHieEOS.Create ;
    ghw_hie_signal :
      Result := TGHWHieSignal.Create ;
    ghw_hie_port_in :
      Result := TGHWHiePortIn.Create ;
    ghw_hie_port_out :
      Result := TGHWHiePortOut.Create ;
    ghw_hie_port_inout :
      Result := TGHWHiePortInOut.Create ;
    ghw_hie_port_buffer :
      Result := TGHWHiePortBuffer.Create ;
    ghw_hie_port_linkage :
      Result := TGHWHiePortLinkage.Create ;
  else
    Result := TGHWHie.Create ;
  end ;
  if not assigned( fHierObjects ) then
    fHierObjects := TObjectlist.Create ;
  fHierObjects.Add( Result ) ;
  Result.Kind := aKind ;
end ;

function TGHWHie.GetDisplayName : string ;
begin
  Result := string( name ) ;
  if assigned( SignalType ) then
    Result := Result + ' ' + SignalType.DisplayName ;
end ;

function TGHWHie.GetSignalType : TGHWType ;
begin
  Result := fSignalType ;
end ;

procedure TGHWHie.SetKind( const Value : ghw_hie_kind_t ) ;
begin
  fKind := Value ;
end ;

procedure TGHWHie.SetSignals( const Value : TGHWSignal ) ;
begin
  fSignals := Value ;
end ;

procedure TGHWHie.SetSignalType( const Value : TGHWType ) ;
begin
  fSignalType := Value ;
end ;

{ TGHWRange }

function TGHWRange.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

class procedure TGHWRange.Clear ;
begin
  FreeAndNil( fRanges ) ;
end ;

class function TGHWRange.Factory : TGHWRange ;
begin
  Result := TGHWRange.Create ;
  if not assigned( fRanges ) then
    fRanges := TObjectlist.Create ;
  fRanges.Add( Result ) ;
end ;

function TGHWRange.GetDisplayName : string ;
const
  cDir : array [ boolean ] of string = ( 'to', 'downto' ) ;
begin
  Result := Format( '(%.3g %s %.3g)', [ Left, cDir[ Dir ], Right ] ) ;
end ;

function TGHWRange.GetLength : integer ;
begin
  Result := 0 ;
  case Kind of
    ghdl_rtik_type_e8, ghdl_rtik_type_i32 :
      if Dir then
        Result := Round( Left - Right + 1 )
      else
        Result := Round( Right - Left + 1 ) ;
  else
    assert( false, Format( 'Range.Length: unhandled kind "%s"', [ gReader.KindToString( Kind ) ] ) ) ;
  end ;
end ;

function TGHWRange.IndexToRange( aIndex : integer ) : integer ;
begin
  if Dir then
    Result := Round( Left - aIndex )
  else
    Result := Round( Left + aIndex ) ;
end ;

procedure TGHWRange.SetDir( const Value : boolean ) ;
begin
  fDir := Value ;
end ;

procedure TGHWRange.SetLeft( const Value : double ) ;
begin
  fLeft := Value ;
end ;

procedure TGHWRange.SetRight( const Value : double ) ;
begin
  fRight := Value ;
end ;

{ TGHWSubTypeArray }

function TGHWSubTypeArray.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

destructor TGHWSubTypeArray.Destroy ;
begin
  fRanges := nil ;
  inherited ;
end ;

function TGHWSubTypeArray.GetChoices : TGHWFormatChoices ;
begin
  Result := BaseType.Choices ;
end ;

function TGHWSubTypeArray.GetDisplayName : string ;
var
  i : integer ;
begin
  Result := '' ;
  for i := 0 to Length( fRanges ) - 1 do
    Result := Result + fRanges[ i ].DisplayName ;
end ;

function TGHWSubTypeArray.GetFormat : TGHWValueFormat ;
begin
  Result := BaseType.ValueFormat ;
end ;

function TGHWSubTypeArray.GetNbrOfElem : integer ;
begin
  Result := fNbrOfElem ;
end ;

function TGHWSubTypeArray.GetNbrOfRanges : integer ;
begin
  Result := Length( fRanges ) ;
end ;

function TGHWSubTypeArray.GetRanges( index : integer ) : TGHWRange ;
begin
  Result := fRanges[ index ] ;
end ;

procedure TGHWSubTypeArray.SetNbrOfElem( aValue : integer ) ;
begin
  fNbrOfElem := aValue ;
end ;

procedure TGHWSubTypeArray.SetNbrOfRanges( const Value : integer ) ;
begin
  Setlength( fRanges, Value ) ;
end ;

procedure TGHWSubTypeArray.SetRanges( index : integer ;

  const Value : TGHWRange ) ;
begin
  fRanges[ index ] := Value ;
end ;

function TGHWSubTypeArray.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
var
  v, b, m : uint64 ;
  r, l : integer ;
  i : integer ;
  iWKT : TGHWTypeEnum ;
  iStr : string ;
begin
  v := 0 ;
  b := 0 ;
  r := 0 ;
  Result := '' ;
  iStr := '' ;
  if NbrOfRanges = 1 then begin
    l := fRanges[ 0 ].Length ;
    // Result := Format( '%dx"%s"', [ l, Copy( 'UUUUUUUUUUUUUUUU', 1, ( l + 3 ) div 4 ) ] ) ;
    m := $FFFFFFFFFFFFFFFF ;
    for i := 0 to aSig.Count - 1 do begin
      if aSig.Signals[ i ].SignalType.BaseType is TGHWTypeEnum then begin
        iWKT := aSig.Signals[ i ].SignalType.BaseType as TGHWTypeEnum ;
        case iWKT.fWKT of
          ghw_wkt_unknown : begin
              iStr := iStr + aSig.Signals[ i ].AsString( aTime ) ;
              if i < aSig.Count - 1 then
                Continue
              else
                Exit( iStr ) ;
            end ;
          ghw_wkt_boolean, ghw_wkt_bit : begin
              b := ( aSig.Signals[ i ] as TGHWSignal ).ValueAt( aTime ).i64 ;
              r := Ranges[ 0 ].IndexToRange( i ) ;
            end ;
          ghw_wkt_std_ulogic : begin
              r := Ranges[ 0 ].IndexToRange( i ) ;
              case TSLVType( ( aSig.Signals[ i ] as TGHWSignal ).ValueAt( aTime ).i64 ) of
                slv0, slvL :
                  b := 0 ;
                slv1, slvH :
                  b := 1 ;
              else
                m := m and not( 1 shl r ) ;
                b := 0 ;
              end ;
            end ;
        else
          Result := '?' + aSig.ClassName ;
          Exit ;
        end ;
        b := b shl r ;
        v := v or b ;
      end
      else begin
        Result := '{array}' ; // '?' + aSig.Signals[ i ].SignalType.BaseType.ClassName ;
        Exit ;
      end ;
      case aFmt of
        fmtBinary :
          Result := BinFormat( l, v, m ) ;
        fmtOctal :
          Result := OctFormat( l, v, m ) ;
        fmtDecimal :
          Result := Format( '%dd"%d"', [ aSig.Count, v ] ) ;
        fmtNone, fmtHex :
          Result := HexFormat( l, v, m ) ;
        fmtPB3 :
          Result := PB3Format( l, v, m ) ;
        fmtPB6 :
          Result := PB6Format( l, v, m ) ;
      end ;
    end ;
  end
  else
    Result := '?' + aSig.ClassName ;
end ;

function TGHWSubTypeArray.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
var
  v, m : uint64 ;
  l : integer ;
begin
  l := fRanges[ 0 ].Length ;
  v := aSig.Events[ aIndex ].val.i64 ;
  m := High( uint64 ) ;
  case aFmt of
    fmtBinary :
      Result := BinFormat( l, v, m ) ;
    fmtOctal :
      Result := OctFormat( l, v, m ) ;
    fmtDecimal :
      Result := Format( '%dd"%d"', [ aSig.Count, v ] ) ;
    fmtNone, fmtHex :
      Result := HexFormat( l, v, m ) ;
    fmtPB3 :
      Result := PB3Format( l, v, m ) ;
    fmtPB6 :
      Result := PB6Format( l, v, m ) ;
  end ;
end ;

{ TGHWTypeRecord }

function TGHWTypeRecord.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

destructor TGHWTypeRecord.Destroy ;
var
  i, l : integer ;
begin
  l := Length( fRecElems ) ;
  for i := 0 to l - 1 do
    fRecElems[ i ].typ := nil ;
  fRecElems := nil ;
  inherited ;
end ;

function TGHWTypeRecord.GetChoices : TGHWFormatChoices ;
begin
  Result := [ fmtNone ] ;
end ;

function TGHWTypeRecord.GetDisplayName : string ;
begin
  Result := '(record)' ;
end ;

function TGHWTypeRecord.GetFormat : TGHWValueFormat ;
begin
  Result := fmtNone ;
end ;

function TGHWTypeRecord.GetNbrOfElem : integer ;
begin
  Result := Length( fRecElems ) ;
end ;

function TGHWTypeRecord.GetRecElems( index : integer ) : TGHWRecordElement ;
begin
  Result := fRecElems[ index ] ;
end ;

procedure TGHWTypeRecord.SetNbrOfElem( aValue : integer ) ;
begin
  Setlength( fRecElems, aValue ) ;
end ;

procedure TGHWTypeRecord.SetRecElems( index : integer ;

  const Value : TGHWRecordElement ) ;
begin
  fRecElems[ index ] := Value ;
end ;

function TGHWTypeRecord.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := '?' + ClassName ;
end ;

function TGHWTypeRecord.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
begin
  Result := '?' + ClassName ;
end ;

{ TGHWTypeArray }

function TGHWTypeArray.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

destructor TGHWTypeArray.Destroy ;
begin
  fDims := nil ;
  inherited ;
end ;

function TGHWTypeArray.GetChoices : TGHWFormatChoices ;
begin
  Result := [ fmtNone ] ;
end ;

function TGHWTypeArray.GetDims( index : integer ) : TGHWType ;
begin
  Result := fDims[ index ] ;
end ;

function TGHWTypeArray.GetDisplayName : string ;
var
  i : integer ;
begin
  Result := '' ;
  for i := 0 to Length( fDims ) - 1 do
    Result := Result + '(' + fElemType.DisplayName + ')' ;
end ;

function TGHWTypeArray.GetElementType : TGHWType ;
begin
  Result := fElemType ;
end ;

function TGHWTypeArray.GetFormat : TGHWValueFormat ;
begin
  Result := fmtNone ;
end ;

function TGHWTypeArray.GetNbrOfElem : integer ;
begin
  Result := Length( fDims ) ;
end ;

procedure TGHWTypeArray.SetDims( index : integer ; const Value : TGHWType ) ;
begin
  fDims[ index ] := Value ;
end ;

procedure TGHWTypeArray.SetElementType( const Value : TGHWType ) ;
begin
  fElemType := Value ;
end ;

procedure TGHWTypeArray.SetNbrOfElem( aValue : integer ) ;
begin
  Setlength( fDims, aValue ) ;
end ;

function TGHWTypeArray.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := '?' + ClassName ;
end ;

function TGHWTypeArray.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
begin
  Result := '?' + ClassName ;
end ;

{ TGHWSubTypeScalar }

function TGHWSubTypeScalar.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWSubTypeScalar.GetChoices : TGHWFormatChoices ;
begin
  Result := BaseType.Choices ;
end ;

function TGHWSubTypeScalar.GetDisplayName : string ;
begin
  Result := fRange.DisplayName ;
end ;

function TGHWSubTypeScalar.GetFormat : TGHWValueFormat ;
begin
  Result := BaseType.ValueFormat ;
end ;

procedure TGHWSubTypeScalar.SetRange( const Value : TGHWRange ) ;
begin
  fRange := Value ;
end ;

function TGHWSubTypeScalar.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := BaseType.SignalAsString( aSig, aFmt, aTime ) ;
end ;

function TGHWSubTypeScalar.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
begin
  Result := BaseType.SignalAsString( aSig, aFmt, aIndex ) ;
end ;

{ TGHWTypeEnum }

function TGHWTypeEnum.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

destructor TGHWTypeEnum.Destroy ;
begin
  fLiterals := nil ;
  inherited ;
end ;

function TGHWTypeEnum.GetChoices : TGHWFormatChoices ;
begin
  Result := [ fmtBinary, fmtEnum ] ;
  case fWKT of
    ghw_wkt_unknown :
      Result := [ fmtEnum ] ;
    ghw_wkt_boolean :
      Result := [ fmtEnum ] ;
    ghw_wkt_bit :
      Result := [ fmtBinary ] ;
    ghw_wkt_std_ulogic :
      Result := [ fmtEnum, fmtBinary ] ;
  end ;
end ;

function TGHWTypeEnum.GetDisplayName : string ;
// var
// i : integer ;
// begin
// Result := '(' ;
// for i := 0 to Length( fLiterals ) - 2 do begin
// Result := Result + string( fLiterals[ i ] ) + ', ' ;
// end ;
// Result := Result + fLiterals[ Length( fLiterals ) - 1 ] + ')' ;
begin
  Result := '(enum)' ;
end ;

function TGHWTypeEnum.GetFormat : TGHWValueFormat ;
begin
  Result := fmtEnum ;
end ;

function TGHWTypeEnum.GetLiterals( index : integer ) : string ;
begin
  Result := fLiterals[ index ] ;
end ;

function TGHWTypeEnum.GetNbrOfElem : integer ;
begin
  Result := Length( fLiterals ) ;
end ;

procedure TGHWTypeEnum.SetLiterals( index : integer ; const Value : string ) ;
begin
  fLiterals[ index ] := Value ;
end ;

procedure TGHWTypeEnum.SetNbrOfElem( aValue : integer ) ;
begin
  Setlength( fLiterals, aValue ) ;
end ;

procedure TGHWTypeEnum.SetWKT( const Value : ghw_wkt_type_t ) ;
begin
  fWKT := Value ;
end ;

function TGHWTypeEnum.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
var
  b : byte ;
begin
  Result := '?TypeEnum' ;
  b := aSig.Events[ aIndex ].val.i64 ;
  case fWKT of
    ghw_wkt_unknown :
      if aFmt = fmtEnum then begin
        if b < Length( fLiterals ) then
          Result := fLiterals[ b ] ;
        // remove single quotes
        if Length( Result ) = 3 then begin
          if ( Result[ 1 ] = '''' ) and ( Result[ 3 ] = '''' ) then
            Result := Result[ 2 ] ;
        end ;
      end ;
    ghw_wkt_boolean : begin
        if b = 1 then
          Result := 'true'
        else
          Result := 'false' ;
      end ;
    ghw_wkt_bit : begin
        if b = 1 then
          Result := '1'
        else
          Result := '0' ;
      end ;
    ghw_wkt_std_ulogic :
      if aFmt = fmtEnum then begin
        if b < Length( fLiterals ) then
          Result := fLiterals[ b ] ;
      end ;
  end ;
end ;

function TGHWTypeEnum.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := SignalAsString( aSig, aFmt, aSig.IndexOf( aTime ) ) ;
end ;

{ TGHWTypePhysical }

function TGHWTypePhysical.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

destructor TGHWTypePhysical.Destroy ;
begin
  fUnits := nil ;
  inherited ;
end ;

function TGHWTypePhysical.GetChoices : TGHWFormatChoices ;
begin
  Result := [ fmtDecimal, fmtFloat ] ;
end ;

function TGHWTypePhysical.GetDisplayName : string ;
begin
  Result := '(physical)' ;
end ;

function TGHWTypePhysical.GetFormat : TGHWValueFormat ;
begin
  Result := fmtDecimal ;
end ;

function TGHWTypePhysical.GetNbrOfElem : integer ;
begin
  Result := Length( fUnits ) ;
end ;

function TGHWTypePhysical.GetUnits( index : integer ) : TGHWUnit ;
begin
  Result := fUnits[ index ] ;
end ;

procedure TGHWTypePhysical.SetNbrOfElem( aValue : integer ) ;
begin
  Setlength( fUnits, aValue ) ;
end ;

procedure TGHWTypePhysical.SetUnits( index : integer ; const Value : TGHWUnit ) ;
begin
  fUnits[ index ] := Value ;
end ;

function TGHWTypePhysical.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
const
  si : array [ 0 .. 5 ] of string = ( 'f', 'p', 'n', 'u', 'm', 'e' ) ;
var
  b : int64 ;
  q : int64 ;
begin
  Result := '?' ;
  case Kind of
    ghdl_rtik_type_p32, ghdl_rtik_type_p64 : begin
        q := aSig.Events[ aIndex ].val.i64 ;
        b := 0 ;
        while q >= 1000 do begin
          q := q div 1000 ;
          inc( b ) ;
        end ;
        if q = 0 then
          Result := '0'
        else
          Result := Format( '%d%s', [ q, si[ b ] ] ) ;
      end ;
  end ;
end ;

function TGHWTypePhysical.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := SignalAsString( aSig, aFmt, aSig.IndexOf( aTime ) ) ;
end ;

{ TGHWSignal }

function TGHWSignal.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWSignal.GetCount : integer ;
begin
  Result := 0 ;
end ;

function TGHWSignal.GetDisplayName : string ;
begin
  Result := name + ' ' + fSignalType.DisplayName ;
end ;

function TGHWSignal.GetEvent( index : integer ) : TGHWEvent ;
begin
  Result := fEvents[ index ] ;
end ;

function TGHWSignal.GetEventCount : integer ;
begin
  Result := fNext ;
end ;

function TGHWSignal.GetHint( index : integer ) : string ;
begin
  Result := #13 ;
  Result := Result + Format( 'Type: %s (%s)'#13, //
    [ fSignalType.ClassName, gReader.KindToString( fSignalType.Kind ) ] ) ;
  Result := Result + Format( 'Base: %s (%s)'#13, //
    [ fSignalType.BaseType.ClassName, gReader.KindToString( fSignalType.BaseType.Kind ) ] ) ;

  Result := Result + Format( 'NbrOfSignals: %d'#13, [ Count ] ) ;
  Result := Result + Format( 'NbrOfEvents:  %d'#13, [ EventCount ] ) ;
end ;

function TGHWSignal.GetSignals( index : integer ) : TGHWSignal ;
begin
  Result := nil ;
end ;

function TGHWSignal.HintAt( aTime : int64 ) : string ;
begin
  Result := AsString( aTime ) ;
end ;

function TGHWSignal.IndexOf( aTime : int64 ) : integer ;
var
  l, r, c : integer ;
begin
  c := fNext ;

  Result := -1 ;
  if c = 0 then
    Exit ;

  Result := 0 ;
  if aTime = 0 then
    Exit ;

  // binary search
  l := 0 ;
  r := c - 1 ;
  repeat
    Result := l + ( r - l ) div 2 ;
    if fEvents[ Result ].time < aTime then
      l := Result + 1
    else
      r := Result - 1 ;
  until ( fEvents[ Result ].time = aTime ) or ( r < l ) ;

  while ( fEvents[ Result ].time > aTime ) and ( Result > 0 ) do
    dec( Result ) ;
end ;

procedure TGHWSignal.SetCount( const Value : integer ) ;
begin
end ;

procedure TGHWSignal.SetIndex( const Value : integer ) ;
begin
  fIndex := Value ;
end ;

procedure TGHWSignal.SetSignals( index : integer ; const Value : TGHWSignal ) ;
begin
end ;

procedure TGHWSignal.SetValueFormat( const Value : TGHWValueFormat ) ;
begin
  fValueFormat := Value ;
end ;

procedure TGHWSignal.SetSignalType( const Value : TGHWType ) ;
begin
  fSignalType := Value ;
end ;

procedure TGHWSignal.AddEvent( aTime : int64 ; aVal : TGHWValue ) ;
var
  iEvent : TGHWEvent ;
begin
  with iEvent do begin
    time := aTime ;
    val := aVal ;
    idx := fIndex ;
  end ;
  AddEvent( iEvent ) ;
end ;

procedure TGHWSignal.AddEvent( aEvent : TGHWEvent ) ;
var
  l : integer ;
begin
  l := Length( fEvents ) ;
  if fNext >= l then
    Setlength( fEvents, 4 * l div 3 + 1 ) ;
  fEvents[ fNext ] := aEvent ;
  inc( fNext ) ;
end ;

function TGHWSignal.AsString( aTime : int64 ) : string ;
begin
  Result := SignalType.BaseType.SignalAsString( Self, fValueFormat, aTime ) ;
end ;

function TGHWSignal.AsString( aIndex : integer ) : string ;
begin
  Result := SignalType.BaseType.SignalAsString( Self, fValueFormat, aIndex ) ;
end ;

class procedure TGHWSignal.CleanUp ;
var
  i : integer ;
begin
  for i := 0 to gReader.NbrSignals - 1 do
    if assigned( gReader.Signals[ i ] ) then
      TGHWSignal( gReader.Signals[ i ] ).Resize ;
end ;

class procedure TGHWSignal.Clear ;
begin
  if assigned( fSignals ) then
    FreeAndNil( fSignals ) ;
end ;

constructor TGHWSignal.Create ;
begin
  // fSignals := nil ;
end ;

destructor TGHWSignal.Destroy ;
begin
  fEvents := nil ;
  inherited ;
end ;

class function TGHWSignal.Factory( aType : TGHWType ; index : integer = 0 ) : TGHWSignal ;
begin
  Result := nil ;
  case aType.Kind of
    ghdl_rtik_subtype_array, ghdl_rtik_subtype_array_ptr : begin
        Result := TGHWSignalArray.Create ;
        if not assigned( fSignals ) then
          fSignals := TObjectlist.Create ;
        fSignals.Add( Result ) ;
        Result.SignalType := aType ;
        Result.ValueFormat := aType.ValueFormat ;
      end ;
    ghdl_rtik_type_record : begin
        Result := TGHWSignalRecord.Create ;
        if not assigned( fSignals ) then
          fSignals := TObjectlist.Create ;
        fSignals.Add( Result ) ;
        Result.SignalType := aType ;
        Result.ValueFormat := aType.ValueFormat ;
      end ;
  else
    assert( index < gReader.NbrSignals, Format( 'Signal.Factory: signal count %d, index: %d',
      [ gReader.NbrSignals, index ] ) ) ;

    if not assigned( gReader.Signals[ index ] ) then begin
      Result := TGHWSignal.Create ;
      Result.SignalType := aType ;
      gReader.Signals[ index ] := Result ;
      Result.ValueFormat := aType.ValueFormat ;
    end
    else if gReader.Signals[ index ] is TGHWSignal then begin
      Result := gReader.Signals[ index ] as TGHWSignal ;
      if not assigned( Result.SignalType ) then
        Result.SignalType := aType ;
    end
    else
      assert( false, 'Signal.Factory: signal type' ) ;
  end ;
end ;

procedure TGHWSignal.ReadCycle( aTime : int64 ) ;
var
  val : TGHWValue ;
begin
  TGHWLib.ReadValue( SignalType, val ) ;
  AddEvent( aTime, val ) ;
end ;

procedure TGHWSignal.Resize ;
begin
  Setlength( fEvents, fNext ) ;
end ;

function TGHWSignal.ValueAt( aTime : int64 ) : TGHWValue ;
var
  l, r, m, c : integer ;
begin
  Result.i64 := 0 ;
  c := fNext ;
  if c = 0 then
    Exit ;

  // binary search
  l := 0 ;
  r := c - 1 ;
  repeat
    m := l + ( r - l ) div 2 ;
    if fEvents[ m ].time < aTime then
      l := m + 1
    else
      r := m - 1 ;
  until ( fEvents[ m ].time = aTime ) or ( r < l ) ;

  // correct to closest lower entry, if no exact match
  while ( fEvents[ m ].time > aTime ) and ( m > 0 ) do
    dec( m ) ;
  Result := fEvents[ m ].val ;
end ;

{ TGHWHieDesign }

function TGHWHieDesign.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieInstance }

function TGHWHieInstance.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWHieInstance.GetHint( index : integer ) : string ;
begin
  Result := '' ;
  case index of
    1 : begin
        Result := 'instance: ' + name ;
        if assigned( fSignals ) then
          Result := Result + ' ' + fSignals.Hint[ index ] ;
      end ;
    2 :
      Result := 'instance: ' + name ;
  end ;
end ;

{ TGHWHieBlock }

function TGHWHieBlock.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieGenerateIf }

function TGHWHieGenerateIf.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieGenerateFor }

function TGHWHieGenerateFor.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieProcess }

function TGHWHieProcess.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieGeneric }

function TGHWHieGeneric.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieEOS }

function TGHWHieEOS.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHiePackage }

function TGHWHiePackage.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieSignal }

function TGHWHieSignal.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWHieSignal.GetHint( index : integer ) : string ;
begin
  Result := '' ;
  case index of
    1 : begin
        Result := 'signal: ' + name ;
        if assigned( fSignals ) then
          Result := Result + ' ' + fSignals.Hint[ index ] ;
      end ;
    2 :
      Result := '' ;
  end ;
end ;

function TGHWHieSignal.HintAt( aTime : int64 ) : string ;
begin
  Result := '<??>' ;
  if assigned( fSignals ) then
    Result := fSignals.HintAt( aTime ) ;
end ;

{ TGHWHiePortIn }

function TGHWHiePortIn.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHiePortOut }

function TGHWHiePortOut.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHiePortInOut }

function TGHWHiePortInOut.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHiePortBuffer }

function TGHWHiePortBuffer.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHiePortLinkage }

function TGHWHiePortLinkage.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWHieEOH }

function TGHWHieEOH.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

{ TGHWSignalArray }

function TGHWSignalArray.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWSignalArray.AsString( aTime : int64 ) : string ;
begin
  Result := fSignalType.SignalAsString( Self, fValueFormat, aTime ) ;
end ;

function TGHWSignalArray.AsString( aIndex : integer ) : string ;
begin
  Result := fSignalType.SignalAsString( Self, fValueFormat, aIndex ) ;
end ;

constructor TGHWSignalArray.Create ;
begin
  fSignals := TObjectlist.Create( false ) ;
end ;

destructor TGHWSignalArray.Destroy ;
begin
  fSignals.Free ;
  inherited ;
end ;

function TGHWSignalArray.GetCount : integer ;
begin
  Result := fSignals.Count ;
end ;

procedure TGHWSignalArray.QuickSort( l, r : integer ) ;
var
  i, j : integer ;
  P, t : TGHWEvent ;
begin
  repeat
    i := l ;
    j := r ;
    P := fEvents[ ( l + r ) shr 1 ] ;
    repeat
      while fEvents[ i ].time < P.time do
        inc( i ) ;
      while fEvents[ j ].time > P.time do
        dec( j ) ;
      if i <= j then begin
        if i <> j then begin
          t := fEvents[ i ] ;
          fEvents[ i ] := fEvents[ j ] ;
          fEvents[ j ] := t ;
        end ;
        inc( i ) ;
        dec( j ) ;
      end ;
    until i > j ;
    if l < j then
      QuickSort( l, j ) ;
    l := i ;
  until i >= r ;
end ;

function TGHWSignalArray.GetEventCount : integer ;
const
  delta = 1000 ;
var
  i, j, c, iCount : integer ;
  iEvent : TGHWEvent ;
  iType : TGHWSubTypeArray ;
  val : uint64 ;
begin
  Result := fNext ;
  if Result <> 0 then
    Exit ;

  if fSignalType is TGHWSubTypeArray then
    iType := fSignalType as TGHWSubTypeArray
  else
    Exit ;

  iCount := Min( Count, 32 ) ;
  for i := 0 to iCount - 1 do begin
    c := Signals[ i ].EventCount ;
    for j := 0 to c - 1 do begin
      iEvent := Signals[ i ].Events[ j ] ;
      iEvent.idx := iType.Ranges[ 0 ].IndexToRange( i ) ;
      AddEvent( iEvent ) ;
    end ;
  end ;
  QuickSort( 0, fNext ) ;

  i := 0 ;
  val := 0 ; // fEvents[ 0 ].val.i64 ;
  while i < fNext do begin
    case TSLVType( fEvents[ i ].val.i64 ) of
      slv1, slvH :
        val := val or ( 1 shl fEvents[ j ].idx ) ;
      slv0, slvL :
        val := val and not( 1 shl fEvents[ j ].idx ) ;
    end ;
    j := i + 1 ;
    while ( j < fNext ) and ( abs( fEvents[ i ].time - fEvents[ j ].time ) < delta ) do begin
      case TSLVType( fEvents[ j ].val.i64 ) of
        slv1, slvH :
          val := val or ( 1 shl fEvents[ j ].idx ) ;
        slv0, slvL :
          val := val and not( 1 shl fEvents[ j ].idx ) ;
      end ;
      fEvents[ j ].time := High( int64 ) ;
      inc( j ) ;
    end ;
    fEvents[ i ].val.i64 := val ;
    i := j ;
  end ;

  QuickSort( 0, fNext ) ;
  while ( fNext > 0 ) and ( fEvents[ fNext - 1 ].time = High( int64 ) ) do
    dec( fNext ) ;
  Setlength( fEvents, fNext ) ;

  Result := fNext ;
end ;

function TGHWSignalArray.GetSignals( index : integer ) : TGHWSignal ;
begin
  Result := fSignals[ index ] as TGHWSignal ;
end ;

procedure TGHWSignalArray.SetCount( const Value : integer ) ;
begin
  fSignals.Count := Value ;
end ;

procedure TGHWSignalArray.SetSignals( index : integer ; const Value : TGHWSignal ) ;
begin
  fSignals[ index ] := Value ;
end ;

{ TGHWSignalRecord }

function TGHWSignalRecord.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWSignalRecord.AsString( aTime : int64 ) : string ;
var
  i : integer ;
begin
  Result := '' ;
  if Count > 0 then
    Result := Signals[ 0 ].AsString( aTime ) ;
  for i := 1 to Count - 1 do
    Result := Result + ',' + Signals[ i ].AsString( aTime ) ;
end ;

function TGHWSignalRecord.AsString( aIndex : integer ) : string ;
var
  i : integer ;
begin
  Result := '' ;
  if Count > 0 then
    Result := Signals[ 0 ].AsString( aIndex ) ;
  for i := 1 to Count - 1 do
    Result := Result + ',' + Signals[ i ].AsString( aIndex ) ;
end ;

{ TGHWTypeScalar }

function TGHWTypeScalar.Accept( Visitor : TGHWVisitor ) : TObject ;
begin
  Result := Visitor.Visit( Self ) ;
end ;

function TGHWTypeScalar.GetChoices : TGHWFormatChoices ;
begin
  Result := [ fmtDecimal, fmtFloat ] ;
end ;

function TGHWTypeScalar.GetDisplayName : string ;
begin
  Result := '(scalar)' ;
end ;

function TGHWTypeScalar.GetFormat : TGHWValueFormat ;
begin
  Result := fmtDecimal ;
end ;

function TGHWTypeScalar.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aIndex : integer ) : string ;
var
  f : double ;
  q : int64 ;
begin
  case Kind of
    ghdl_rtik_type_f64 : begin
        f := aSig.Events[ aIndex ].val.f64 ;
        if aFmt in [ fmtDecimal, fmtFloat ] then
          Result := Format( '%g', [ f ] ) ;
      end ;
    ghdl_rtik_type_i32, ghdl_rtik_type_i64 : begin
        q := aSig.Events[ aIndex ].val.i64 ;
        if aFmt in [ fmtDecimal, fmtFloat ] then
          Result := Format( '%d', [ q ] ) ;
      end ;
  else
    Result := Format( '?%d?', [ Ord( Kind ) ] ) ;
  end ;
end ;

function TGHWTypeScalar.SignalAsString( aSig : TGHWSignal ; aFmt : TGHWValueFormat ; aTime : int64 ) : string ;
begin
  Result := SignalAsString( aSig, aFmt, aSig.IndexOf( aTime ) ) ;
end ;

{ TGHWTypeBased }

function TGHWTypeBased.GetBasetype : TGHWType ;
begin
  Result := fBaseType ;
end ;

procedure TGHWTypeBased.SetBaseType( const Value : TGHWType ) ;
begin
  fBaseType := Value ;
end ;

initialization

gReader := TGHWReader.Create ;

finalization

gReader.Free ;

end.
